{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances,
      PatternGuards, TupleSections, NamedFieldPuns #-}

module TypeChecker where

import Prelude hiding (null)

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Monad          (foldM, forM, forM_, liftM, unless, when, zipWithM, zipWithM_)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.State    (runStateT, get, gets, put)
import Control.Monad.Except   (runExceptT, catchError)
import Control.Monad.Reader   (runReaderT, ask, asks, local)

import qualified Data.List as List
import Data.Map (Map)
import Data.Maybe
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable

-- import Debug.Trace (trace)

import qualified Text.PrettyPrint as PP

import Util

import Abstract hiding (Substitute)
import Polarity as Pol
import Value
import TCM
import Eval
import Extract
-- import CallStack
import PrettyTCM
import TraceError

import Termination

-- import Completness

traceCheck, traceSing, traceAdm :: String -> a -> a
traceCheckM, traceSingM, traceAdmM :: Monad m => String -> m ()


traceCheck :: forall a. String -> a -> a
traceCheck String
msg a
a = a
a -- trace msg a
traceCheckM :: forall (m :: * -> *). Monad m => String -> m ()
traceCheckM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- traceM msg
{-
traceCheck msg a = trace msg a
traceCheckM msg = traceM msg
-}

traceSing :: forall a. String -> a -> a
traceSing String
msg a
a = a
a -- trace msg a
traceSingM :: forall (m :: * -> *). Monad m => String -> m ()
traceSingM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- traceM msg
{-
traceSing msg a = trace msg a
traceSingM msg = traceM msg
-}

traceAdm :: forall a. String -> a -> a
traceAdm String
msg a
a = a
a -- trace msg a
traceAdmM :: forall (m :: * -> *). Monad m => String -> m ()
traceAdmM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- traceM msg
{-
traceAdm msg a = trace msg a
traceAdmM msg = traceM msg
-}

{- DEAD CODE
runWhnf :: Signature -> TypeCheck a -> IO (Either TraceError (a,Signature))
runWhnf sig tc = (runExceptT (runStateT tc  sig))
-}

doNf :: Signature -> Expr -> IO (Either TraceError (Expr, TCState))
doNf :: Signature -> Expr -> IO (Either TraceError (Expr, TCState))
doNf Signature
sig Expr
e = ExceptT TraceError IO (Expr, TCState)
-> IO (Either TraceError (Expr, TCState))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT TCContext (ExceptT TraceError IO) (Expr, TCState)
-> TCContext -> ExceptT TraceError IO (Expr, TCState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
-> TCState
-> ReaderT TCContext (ExceptT TraceError IO) (Expr, TCState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Env -> Expr -> TypeCheck TVal
whnf Env
forall a. Environ a
emptyEnv Expr
e TypeCheck TVal
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
reify) (Signature -> TCState
initWithSig Signature
sig)) TCContext
emptyContext)

doWhnf :: Signature -> Expr -> IO (Either TraceError (Val, TCState))
doWhnf :: Signature -> Expr -> IO (Either TraceError (TVal, TCState))
doWhnf Signature
sig Expr
e = ExceptT TraceError IO (TVal, TCState)
-> IO (Either TraceError (TVal, TCState))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT TCContext (ExceptT TraceError IO) (TVal, TCState)
-> TCContext -> ExceptT TraceError IO (TVal, TCState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (TypeCheck TVal
-> TCState
-> ReaderT TCContext (ExceptT TraceError IO) (TVal, TCState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Env -> Expr -> TypeCheck TVal
whnf Env
forall a. Environ a
emptyEnv Expr
e TypeCheck TVal -> (TVal -> TypeCheck TVal) -> TypeCheck TVal
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVal -> TypeCheck TVal
whnfClos) (Signature -> TCState
initWithSig Signature
sig)) TCContext
emptyContext)


-- top-level functions -------------------------------------------

runTypeCheck :: TCState -> TypeCheck a -> IO (Either TraceError (a, TCState))
runTypeCheck :: forall a.
TCState -> TypeCheck a -> IO (Either TraceError (a, TCState))
runTypeCheck TCState
st TypeCheck a
tc = ExceptT TraceError IO (a, TCState)
-> IO (Either TraceError (a, TCState))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT TCContext (ExceptT TraceError IO) (a, TCState)
-> TCContext -> ExceptT TraceError IO (a, TCState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (TypeCheck a
-> TCState
-> ReaderT TCContext (ExceptT TraceError IO) (a, TCState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT TypeCheck a
tc TCState
st) TCContext
emptyContext)
-- runTypeCheck st tc = runCallStackT (runReaderT (runStateT tc st) emptyContext) []

typeCheck :: [Declaration] -> IO (Either TraceError ([EDeclaration], TCState))
typeCheck :: [Declaration] -> IO (Either TraceError ([Declaration], TCState))
typeCheck [Declaration]
dl = TCState
-> TypeCheck [Declaration]
-> IO (Either TraceError ([Declaration], TCState))
forall a.
TCState -> TypeCheck a -> IO (Either TraceError (a, TCState))
runTypeCheck TCState
initSt ([Declaration] -> TypeCheck [Declaration]
typeCheckDecls [Declaration]
dl)

-- checking top-level declarations -------------------------------

echo :: MonadIO m => String -> m ()
echo :: forall (m :: * -> *). MonadIO m => String -> m ()
echo = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

echoR :: MonadIO m => String -> m ()
echoR :: forall (m :: * -> *). MonadIO m => String -> m ()
echoR = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
echo
-- echoR s = echo $ "R> " ++ s

echoTySig :: (Show n, MonadIO m) => n -> Expr -> m ()
echoTySig :: forall n (m :: * -> *). (Show n, MonadIO m) => n -> Expr -> m ()
echoTySig n
n Expr
t = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- echo $ "I> " ++ n ++ " : " ++ show t

echoKindedTySig :: (Show n, MonadIO m) => Kind -> n -> Expr -> m ()
echoKindedTySig :: forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedTySig Kind
ki n
n Expr
t = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
echo (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ Kind -> String
prettyKind Kind
ki String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t

echoKindedDef :: (Show n, MonadIO m) => Kind -> n -> Expr -> m ()
echoKindedDef :: forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedDef Kind
ki n
n Expr
t = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
echo (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ Kind -> String
prettyKind Kind
ki String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t

echoEPrefix :: String
echoEPrefix :: String
echoEPrefix = String
"E> "

echoTySigE :: (Show n, MonadIO m) => n -> Expr -> m ()
echoTySigE :: forall n (m :: * -> *). (Show n, MonadIO m) => n -> Expr -> m ()
echoTySigE n
n Expr
t = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
echo (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
echoEPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t

echoDefE :: (Show n, MonadIO m) => n -> Expr -> m ()
echoDefE :: forall n (m :: * -> *). (Show n, MonadIO m) => n -> Expr -> m ()
echoDefE n
n Expr
t = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
echo (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
echoEPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t

-- the type checker returns pruned (extracted) terms
-- with irrelevant subterms replaced by Irr
typeCheckDecls :: [Declaration] -> TypeCheck [EDeclaration]
typeCheckDecls :: [Declaration] -> TypeCheck [Declaration]
typeCheckDecls []     = [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
typeCheckDecls (Declaration
d:[Declaration]
ds) = do
  [Declaration]
de  <- Declaration -> TypeCheck [Declaration]
typeCheckDeclaration Declaration
d
  [Declaration]
dse <- [Declaration] -> TypeCheck [Declaration]
typeCheckDecls [Declaration]
ds
  [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration]
de [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
dse)

-- since a data declaration generates destructor declarations
-- we need to return a list here
typeCheckDeclaration :: Declaration -> TypeCheck [EDeclaration]
typeCheckDeclaration :: Declaration -> TypeCheck [Declaration]
typeCheckDeclaration (OverrideDecl Override
Check [Declaration]
ds) = do
  TCState
st <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TCState
forall s (m :: * -> *). MonadState s m => m s
get
  [Declaration]
_ <- [Declaration] -> TypeCheck [Declaration]
typeCheckDecls [Declaration]
ds
  TCState
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TCState
st             -- forget the effect of these decls
  [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
typeCheckDeclaration (OverrideDecl Override
Fail [Declaration]
ds) = do
  TCState
st <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TCState
forall s (m :: * -> *). MonadState s m => m s
get
  Bool
r <- ([Declaration] -> TypeCheck [Declaration]
typeCheckDecls [Declaration]
ds TypeCheck [Declaration]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> (TraceError
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (TraceError
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
        (\ TraceError
s -> do IO ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
IO a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> IO ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"block fails as expected, error message:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TraceError -> String
forall a. Show a => a -> String
show TraceError
s)
                   Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
  if Bool
r then String -> TypeCheck [Declaration]
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
"unexpected success" else do
    TCState
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TCState
st
    [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []

typeCheckDeclaration (OverrideDecl Override
TrustMe [Declaration]
ds) =
  AssertionHandling
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a.
AssertionHandling
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadAssert m =>
AssertionHandling -> m a -> m a
newAssertionHandling AssertionHandling
Warning (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ [Declaration] -> TypeCheck [Declaration]
typeCheckDecls [Declaration]
ds

typeCheckDeclaration (OverrideDecl Override
Impredicative [Declaration]
ds) =
  TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
goImpredicative (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ [Declaration] -> TypeCheck [Declaration]
typeCheckDecls [Declaration]
ds

typeCheckDeclaration (RecordDecl Name
n Telescope
tel Expr
t0 Constructor
c [Name]
fields) =
  -- just one "mutual" declaration
  Maybe DefId -> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a.
Maybe DefId
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Maybe DefId -> m a -> m a
checkingMutual (DefId -> Maybe DefId
forall a. a -> Maybe a
Just (DefId -> Maybe DefId) -> DefId -> Maybe DefId
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
DatK (QName -> DefId) -> QName -> DefId
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n) (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ do
    [Declaration]
result <- Name
-> Sized
-> Co
-> [Pol]
-> Telescope
-> Expr
-> [Constructor]
-> [Name]
-> TypeCheck [Declaration]
typeCheckDataDecl Name
n Sized
NotSized Co
CoInd [] Telescope
tel Expr
t0 [Constructor
c] [Name]
fields
    StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkPositivityGraph
    [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
result

typeCheckDeclaration (DataDecl Name
n Sized
sz Co
co [Pol]
pos0 Telescope
tel Expr
t0 [Constructor]
cs [Name]
fields) =
  -- just one "mutual" declaration
  Maybe DefId -> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a.
Maybe DefId
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Maybe DefId -> m a -> m a
checkingMutual (DefId -> Maybe DefId
forall a. a -> Maybe a
Just (DefId -> Maybe DefId) -> DefId -> Maybe DefId
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
DatK (QName -> DefId) -> QName -> DefId
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n) (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ do
    [Declaration]
result <- Name
-> Sized
-> Co
-> [Pol]
-> Telescope
-> Expr
-> [Constructor]
-> [Name]
-> TypeCheck [Declaration]
typeCheckDataDecl Name
n Sized
sz Co
co [Pol]
pos0 Telescope
tel Expr
t0 [Constructor]
cs [Name]
fields
    StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkPositivityGraph
    [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
result

typeCheckDeclaration (LetDecl Bool
eval Name
n Telescope
tel Maybe Expr
mt Expr
e) = String -> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (Name -> String
forall a. Show a => a -> String
show Name
n) (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ do
{- MOVED to checkLetDef
  (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer neutralDec e mt
  te <- return $ teleToType tel te
  ee <- return $ teleLam tel ee
  vt <- whnf' te
-}
  (TVal
vt, Expr
te, Kinded Kind
ki Expr
ee) <- Dec
-> Telescope
-> Maybe Expr
-> Expr
-> TypeCheck (TVal, Expr, Kinded Expr)
checkLetDef Dec
neutralDec Telescope
tel Maybe Expr
mt Expr
e
  Env
rho <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall (m :: * -> *). MonadCxt m => m Env
getEnv -- is emptyEnv
  -- TODO: solve size constraints
  -- does not work with emptyEnv
  -- [te, ee] <- solveAndModify [te, ee] rho  -- solve size constraints
  let v :: TVal
v = Env -> Expr -> TVal
mkClos Env
rho Expr
ee -- delay whnf computation
  -- v  <- whnf' ee -- WAS: whnf' e'
  Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
n (TVal -> Kind -> TVal -> Expr -> SigDef
LetSig TVal
vt Kind
ki TVal
v (Expr -> SigDef) -> Expr -> SigDef
forall a b. (a -> b) -> a -> b
$ QName -> Expr
undefinedFType (QName -> Expr) -> QName -> Expr
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n)    -- late (var -> expr) binding, but ok since no shadowing
--  addSig n (LetSig vt e')    -- late (var -> expr) binding, but ok since no shadowing
  Kind
-> Name
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedTySig Kind
ki Name
n Expr
te
--  echoTySigE n te
--  echoDefE   n ee
  Kind
-> Name
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedDef Kind
ki Name
n Expr
ee
  [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> Name -> Telescope -> Maybe Expr -> Expr -> Declaration
LetDecl Bool
eval Name
n Telescope
emptyTel (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
te) Expr
ee]

typeCheckDeclaration d :: Declaration
d@(PatternDecl Name
x [Name]
xs Pattern
p) = do
{- WHY DOES THIS NOT TYPECHECK?
  let doc = (PP.text "pattern") <+> (PP.hsep (List.map Util.pretty (x:xs))) <+> PP.equals <+> Util.pretty p
  echo $ PP.render $ doc
-}
  String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadIO m => String -> m ()
echo (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Name -> String) -> [Name] -> String
forall a. String -> (a -> String) -> [a] -> String
Util.showList String
" " Name -> String
forall a. Show a => a -> String
show (Name
xName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p
  TVal
v <- Expr -> TypeCheck TVal
whnf' (Expr -> TypeCheck TVal) -> Expr -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ (Name -> Expr -> Expr) -> Expr -> [Name] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Dec -> Name -> Expr -> Expr
Lam Dec
defaultDec) (Pattern -> Expr
patternToExpr Pattern
p) [Name]
xs
  Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
x ([Name] -> Pattern -> TVal -> SigDef
PatSig [Name]
xs Pattern
p TVal
v)
  [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration
d]

typeCheckDeclaration (MutualFunDecl Bool
False Co
co [Fun]
funs) =
  -- traceCheck ("type checking a function block") $
  do
    [Fun]
funse <- Co -> [Fun] -> TypeCheck [Fun]
typeCheckFuns Co
co [Fun]
funs
    [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> TypeCheck [Declaration])
-> [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ [Bool -> Co -> [Fun] -> Declaration
MutualFunDecl Bool
False Co
co [Fun]
funse]

typeCheckDeclaration (MutualFunDecl Bool
True Co
co [Fun]
funs) =
  -- traceCheck ("type checking a block of measured function") $
  do
    [Fun]
funse <- Co -> [Fun] -> TypeCheck [Fun]
typeCheckMeasuredFuns Co
co [Fun]
funs
    [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> TypeCheck [Declaration])
-> [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ [Bool -> Co -> [Fun] -> Declaration
MutualFunDecl Bool
False Co
co [Fun]
funse]

typeCheckDeclaration (MutualDecl Bool
measured [Declaration]
ds) = do
  -- first check type signatures
  -- we add the typings into the context, not the signature
  [Kinded (TySig TVal)]
ktss <- [Declaration] -> TypeCheck [Kinded (TySig TVal)]
typeCheckMutualSigs [Declaration]
ds
  -- register the mutually defined names
  let ns :: [Name]
ns = [Kinded (TySig TVal)] -> (Kinded (TySig TVal) -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [Kinded (TySig TVal)]
ktss ((Kinded (TySig TVal) -> Name) -> [Name])
-> (Kinded (TySig TVal) -> Name) -> [Name]
forall a b. (a -> b) -> a -> b
$ \ (Kinded Kind
_ (TypeSig Name
n TVal
_)) -> Name
n
      addMutualNames :: m a -> m a
addMutualNames = (TCContext -> TCContext) -> m a -> m a
forall a. (TCContext -> TCContext) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((TCContext -> TCContext) -> m a -> m a)
-> (TCContext -> TCContext) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \ TCContext
e -> TCContext
e { mutualNames = ns ++ mutualNames e }
  -- then check bodies
  -- we need to construct a positivity graph
  [[Declaration]]
edss <- [Kinded (TySig TVal)]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
forall a.
[Kinded (TySig TVal)]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
[Kinded (TySig TVal)] -> m a -> m a
addKindedTypeSigs [Kinded (TySig TVal)]
ktss (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      [[Declaration]])
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
forall a b. (a -> b) -> a -> b
$ StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
forall {m :: * -> *} {a}. MonadReader TCContext m => m a -> m a
addMutualNames (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      [[Declaration]])
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
forall a b. (a -> b) -> a -> b
$
    (Kind -> Declaration -> TypeCheck [Declaration])
-> [Kind]
-> [Declaration]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Bool -> Kind -> Declaration -> TypeCheck [Declaration]
typeCheckMutualBody Bool
measured) ((Kinded (TySig TVal) -> Kind) -> [Kinded (TySig TVal)] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> Kind
predKind (Kind -> Kind)
-> (Kinded (TySig TVal) -> Kind) -> Kinded (TySig TVal) -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kinded (TySig TVal) -> Kind
forall a. Kinded a -> Kind
kindOf) [Kinded (TySig TVal)]
ktss) [Declaration]
ds
  -- check and reset positivity graph
  StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkPositivityGraph
  [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> TypeCheck [Declaration])
-> [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
edss


-- check signatures of a flattened mutual block
typeCheckMutualSigs :: [Declaration] -> TypeCheck [Kinded (TySig TVal)]
typeCheckMutualSigs :: [Declaration] -> TypeCheck [Kinded (TySig TVal)]
typeCheckMutualSigs [] = [Kinded (TySig TVal)] -> TypeCheck [Kinded (TySig TVal)]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
typeCheckMutualSigs (Declaration
d:[Declaration]
ds) = do
  kts :: Kinded (TySig TVal)
kts@(Kinded Kind
ki (TypeSig Name
n TVal
tv)) <- Declaration -> TypeCheck (Kinded (TySig TVal))
typeCheckMutualSig Declaration
d
  Name
-> Domain
-> TypeCheck [Kinded (TySig TVal)]
-> TypeCheck [Kinded (TySig TVal)]
forall a.
Name
-> Domain
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Name -> Domain -> m a -> m a
new' Name
n (TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
tv Kind
ki Dec
defaultDec) (TypeCheck [Kinded (TySig TVal)]
 -> TypeCheck [Kinded (TySig TVal)])
-> TypeCheck [Kinded (TySig TVal)]
-> TypeCheck [Kinded (TySig TVal)]
forall a b. (a -> b) -> a -> b
$ do
    [Kinded (TySig TVal)]
ktss <- [Declaration] -> TypeCheck [Kinded (TySig TVal)]
typeCheckMutualSigs [Declaration]
ds
    [Kinded (TySig TVal)] -> TypeCheck [Kinded (TySig TVal)]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kinded (TySig TVal)] -> TypeCheck [Kinded (TySig TVal)])
-> [Kinded (TySig TVal)] -> TypeCheck [Kinded (TySig TVal)]
forall a b. (a -> b) -> a -> b
$ Kinded (TySig TVal)
kts Kinded (TySig TVal)
-> [Kinded (TySig TVal)] -> [Kinded (TySig TVal)]
forall a. a -> [a] -> [a]
: [Kinded (TySig TVal)]
ktss

typeCheckSignature :: TySig Type -> TypeCheck (Kinded (TySig TVal))
typeCheckSignature :: TySig Expr -> TypeCheck (Kinded (TySig TVal))
typeCheckSignature (TypeSig Name
n Expr
t) = do
  Name
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *). (Show n, MonadIO m) => n -> Expr -> m ()
echoTySig Name
n Expr
t
  Kinded Kind
ki Expr
te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
  TVal
tv <- Expr -> TypeCheck TVal
whnf' Expr
te
  Kinded (TySig TVal) -> TypeCheck (Kinded (TySig TVal))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded (TySig TVal) -> TypeCheck (Kinded (TySig TVal)))
-> Kinded (TySig TVal) -> TypeCheck (Kinded (TySig TVal))
forall a b. (a -> b) -> a -> b
$ Kind -> TySig TVal -> Kinded (TySig TVal)
forall a. Kind -> a -> Kinded a
Kinded (Kind -> Kind
predKind Kind
ki) (TySig TVal -> Kinded (TySig TVal))
-> TySig TVal -> Kinded (TySig TVal)
forall a b. (a -> b) -> a -> b
$ Name -> TVal -> TySig TVal
forall a. Name -> a -> TySig a
TypeSig Name
n TVal
tv

typeCheckMutualSig :: Declaration -> TypeCheck (Kinded (TySig TVal))
typeCheckMutualSig :: Declaration -> TypeCheck (Kinded (TySig TVal))
typeCheckMutualSig (LetDecl Bool
ev Name
n Telescope
tel (Just Expr
t) Expr
e) =
  TySig Expr -> TypeCheck (Kinded (TySig TVal))
typeCheckSignature (TySig Expr -> TypeCheck (Kinded (TySig TVal)))
-> TySig Expr -> TypeCheck (Kinded (TySig TVal))
forall a b. (a -> b) -> a -> b
$ Name -> Expr -> TySig Expr
forall a. Name -> a -> TySig a
TypeSig Name
n (Expr -> TySig Expr) -> Expr -> TySig Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> Expr -> Expr
teleToType Telescope
tel Expr
t
typeCheckMutualSig (DataDecl Name
n Sized
sz Co
co [Pol]
pos Telescope
tel Expr
t [Constructor]
cs [Name]
fields) = do
  Kinded Kind
ki TySig TVal
ts <- TySig Expr -> TypeCheck (Kinded (TySig TVal))
typeCheckSignature (Name -> Expr -> TySig Expr
forall a. Name -> a -> TySig a
TypeSig Name
n (Telescope -> Expr -> Expr
teleToType Telescope
tel Expr
t))
  Kinded (TySig TVal) -> TypeCheck (Kinded (TySig TVal))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded (TySig TVal) -> TypeCheck (Kinded (TySig TVal)))
-> Kinded (TySig TVal) -> TypeCheck (Kinded (TySig TVal))
forall a b. (a -> b) -> a -> b
$ Kind -> TySig TVal -> Kinded (TySig TVal)
forall a. Kind -> a -> Kinded a
Kinded Kind
ki TySig TVal
ts
typeCheckMutualSig (FunDecl Co
co (Fun TySig Expr
ts Name
n' Arity
ar [Clause]
cls)) =
  TySig Expr -> TypeCheck (Kinded (TySig TVal))
typeCheckSignature TySig Expr
ts
typeCheckMutualSig (OverrideDecl Override
TrustMe [Declaration
d]) =
  AssertionHandling
-> TypeCheck (Kinded (TySig TVal))
-> TypeCheck (Kinded (TySig TVal))
forall a.
AssertionHandling
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadAssert m =>
AssertionHandling -> m a -> m a
newAssertionHandling AssertionHandling
Warning (TypeCheck (Kinded (TySig TVal))
 -> TypeCheck (Kinded (TySig TVal)))
-> TypeCheck (Kinded (TySig TVal))
-> TypeCheck (Kinded (TySig TVal))
forall a b. (a -> b) -> a -> b
$ Declaration -> TypeCheck (Kinded (TySig TVal))
typeCheckMutualSig Declaration
d
typeCheckMutualSig (OverrideDecl Override
Impredicative [Declaration
d]) =
  TypeCheck (Kinded (TySig TVal)) -> TypeCheck (Kinded (TySig TVal))
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
goImpredicative (TypeCheck (Kinded (TySig TVal))
 -> TypeCheck (Kinded (TySig TVal)))
-> TypeCheck (Kinded (TySig TVal))
-> TypeCheck (Kinded (TySig TVal))
forall a b. (a -> b) -> a -> b
$ Declaration -> TypeCheck (Kinded (TySig TVal))
typeCheckMutualSig Declaration
d
typeCheckMutualSig Declaration
d = String -> TypeCheck (Kinded (TySig TVal))
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Kinded (TySig TVal)))
-> String -> TypeCheck (Kinded (TySig TVal))
forall a b. (a -> b) -> a -> b
$ String
"typeCheckMutualSig: panic: unexpected declaration " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Declaration -> String
forall a. Show a => a -> String
show Declaration
d

-- typeCheckMutualBody measured kindCandidate
typeCheckMutualBody :: Bool -> Kind -> Declaration -> TypeCheck [EDeclaration]
typeCheckMutualBody :: Bool -> Kind -> Declaration -> TypeCheck [Declaration]
typeCheckMutualBody Bool
measured Kind
_ (DataDecl Name
n Sized
sz Co
co [Pol]
pos Telescope
tel Expr
t [Constructor]
cs [Name]
fields) = do
  -- set name of mutual thing whose body we are checking
  Maybe DefId -> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a.
Maybe DefId
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Maybe DefId -> m a -> m a
checkingMutual (DefId -> Maybe DefId
forall a. a -> Maybe a
Just (DefId -> Maybe DefId) -> DefId -> Maybe DefId
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
DatK (QName -> DefId) -> QName -> DefId
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n) (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$
    --
    Name
-> Sized
-> Co
-> [Pol]
-> Telescope
-> Expr
-> [Constructor]
-> [Name]
-> TypeCheck [Declaration]
typeCheckDataDecl Name
n Sized
sz Co
co [Pol]
pos Telescope
tel Expr
t [Constructor]
cs [Name]
fields
typeCheckMutualBody measured :: Bool
measured@Bool
False Kind
ki (FunDecl Co
co fun :: Fun
fun@(Fun ts :: TySig Expr
ts@(TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cls)) = do
  Maybe DefId -> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a.
Maybe DefId
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Maybe DefId -> m a -> m a
checkingMutual (DefId -> Maybe DefId
forall a. a -> Maybe a
Just (DefId -> Maybe DefId) -> DefId -> Maybe DefId
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
FunK (QName -> DefId) -> QName -> DefId
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n) (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ do
    Fun
fun' <- Co -> Kind -> Fun -> TypeCheck Fun
typeCheckFunBody Co
co Kind
ki Fun
fun
    [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> TypeCheck [Declaration])
-> [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ [Co -> Fun -> Declaration
FunDecl Co
co Fun
fun']

typeCheckDataDecl :: Name -> Sized -> Co -> [Pol] -> Telescope -> Type -> [Constructor] -> [Name] -> TypeCheck [EDeclaration]
typeCheckDataDecl :: Name
-> Sized
-> Co
-> [Pol]
-> Telescope
-> Expr
-> [Constructor]
-> [Name]
-> TypeCheck [Declaration]
typeCheckDataDecl Name
n Sized
sz Co
co [Pol]
pos0 Telescope
tel0 Expr
t0 [Constructor]
cs0 [Name]
fields = String -> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (Name -> String
forall a. Show a => a -> String
show Name
n) (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$
 (do -- sig <- gets signature
     let params :: Int
params = Telescope -> Int
forall a. Size a => a -> Int
size Telescope
tel0
     -- in case we are dealing with a sized type, check that
     -- the polarity annotation (if present) at the size arg. is correct.
     (Int
p', [Pol]
pos, Expr
t) <- do
       case Sized
sz of
         Sized
Sized    -> do
           let polsz :: Pol
polsz = if Co
coCo -> Co -> Bool
forall a. Eq a => a -> a -> Bool
==Co
Ind then Pol
Pos else Pol
Neg
           Expr
t <- case Expr
t0 of
             Quant PiSigma
Pi (TBind Name
x (Domain Expr
domt Kind
ki Dec
dec)) Expr
b | Expr -> Bool
isSize Expr
domt ->
               case (Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec) of
                 -- insert correct polarity annotation if none was there
                 Pol
pol | Pol
pol Pol -> [Pol] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pol
Param,Pol
Rec] -> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a b. (a -> b) -> a -> b
$ PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Dom Expr -> TBind) -> Dom Expr -> TBind
forall a b. (a -> b) -> a -> b
$ Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
tSize Kind
kSize (Dec -> Dom Expr) -> Dec -> Dom Expr
forall a b. (a -> b) -> a -> b
$ Pol -> Dec -> Dec
forall a. LensPol a => Pol -> a -> a
setPol Pol
polsz Dec
dec) Expr
b
                 Pol
pol | Pol
pol Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
polsz -> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
t0
                 Pol
pol -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a b. (a -> b) -> a -> b
$ String
"sized type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has wrong polarity annotation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
pol String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at Size argument, it should be " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
polsz
             Expr
t0 -> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
t0
           (Int, [Pol], Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Int, [Pol], Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
params Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [Pol]
pos0 [Pol] -> [Pol] -> [Pol]
forall a. [a] -> [a] -> [a]
++ [Pol
polsz], Expr
t)
         Sized
NotSized -> do
           -- Warn if it looks like a sized type, but there was no keyword "sized".
           case Expr
t0 of
             Quant PiSigma
Pi (TBind Name
x (Domain Expr
domt Kind
ki Dec
dec)) Expr
b | Expr -> Bool
isSize Expr
domt -> do
               String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceM (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
" looks like you want to define a sized type, did you forget keyword `sized`?"
             Expr
_ -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           (Int, [Pol], Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Int, [Pol], Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
params, [Pol]
pos0, Expr
t0)
     -- compute full type signature (including parameter telescope)
     let dt :: Expr
dt = (Telescope -> Expr -> Expr
teleToType Telescope
tel0 Expr
t)
     Name
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *). (Show n, MonadIO m) => n -> Expr -> m ()
echoTySig Name
n Expr
dt
     {- mmh, this does not work,  e.g.  data Id (A : Set)(a : A) : A -> Set
        then A -> Set is not distinguishable from Set -> Set (GADT)
        unclear what to do...
     dte <- checkTele tel $ \ tele -> do
       te <- checkSmallType t
       return (teleToType tele te)
      -}
     -- get the target sort ds of the datatype
     Kinded Kind
ki0 (Sort Expr
ds, Expr
dte) <- Int -> Expr -> TypeCheck (Kinded (Sort Expr, Expr))
checkDataType Int
p' Expr
dt -- TODO?: use above code?
     let ki :: Kind
ki = Kind -> Kind
dataKind Kind
ki0
     Kind
-> Name
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedTySig Kind
ki Name
n Expr
dte
--     echoTySigE n dte
     TVal
v <- Env -> Expr -> TypeCheck TVal
whnf Env
forall a. Environ a
emptyEnv Expr
dte
     Just Expr
fkind <- TVal -> TypeCheck (Maybe Expr)
extractKind TVal
v
     -- get the updated telescope which contains the kinds
     let (Telescope
tel, Expr
dtcore) = Int -> Expr -> (Telescope, Expr)
typeToTele' Int
params Expr
dte
     -- compute the constructor telescopes
     [Constructor]
cs0 <- (Constructor
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Constructor)
-> [Constructor]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Constructor]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Telescope
-> Expr
-> Constructor
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Constructor
insertConstructorTele Telescope
tel Expr
dtcore) [Constructor]
cs0
     let cis :: [ConstructorInfo]
cis = Co -> Name -> Telescope -> [Constructor] -> [ConstructorInfo]
analyzeConstructors Co
co Name
n Telescope
tel [Constructor]
cs0
     let cs :: [Constructor]
cs  = (ConstructorInfo -> Constructor)
-> [ConstructorInfo] -> [Constructor]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Constructor
reassembleConstructor [ConstructorInfo]
cis
     Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
n (DataSig { numPars :: Int
numPars = Int
params
                       , positivity :: [Pol]
positivity = [Pol]
pos
                       , isSized :: Sized
isSized = Sized
sz
                       , isCo :: Co
isCo = Co
co
                       , symbTyp :: TVal
symbTyp = TVal
v
                       , symbolKind :: Kind
symbolKind = Kind
ki
                       , constructors :: [ConstructorInfo]
constructors = [ConstructorInfo]
cis
                       , etaExpand :: Bool
etaExpand = Bool
False
                       , isTuple :: Bool
isTuple = Bool
False
-- if cs==[] then Just [] else Nothing
{- OLD CODE
                       , constructors = map namePart cs
                       -- at first, do not add destructors, get them out later
                       , destructors  = Nothing
                       , isFamily = t /= Set  -- currently UNUSED
 -}
                       , extrTyp :: Expr
extrTyp = Expr
fkind
                       })
     Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Sized
sz Sized -> Sized -> Bool
forall a. Eq a => a -> a -> Bool
== Sized
Sized) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
           Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szType Co
co Int
params TVal
v

     ([Bool]
isRecList, [Kinded Constructor]
kcse) <- ([(Bool, Kinded Constructor)] -> ([Bool], [Kinded Constructor]))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [(Bool, Kinded Constructor)]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     ([Bool], [Kinded Constructor])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(Bool, Kinded Constructor)] -> ([Bool], [Kinded Constructor])
forall a b. [(a, b)] -> ([a], [b])
unzip (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   [(Bool, Kinded Constructor)]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      ([Bool], [Kinded Constructor]))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [(Bool, Kinded Constructor)]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     ([Bool], [Kinded Constructor])
forall a b. (a -> b) -> a -> b
$
       (Constructor
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Bool, Kinded Constructor))
-> [Constructor]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [(Bool, Kinded Constructor)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name
-> Expr
-> Sized
-> Co
-> [Pol]
-> Telescope
-> Constructor
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Bool, Kinded Constructor)
typeCheckConstructor Name
n Expr
dte Sized
sz Co
co [Pol]
pos Telescope
tel) [Constructor]
cs

     -- compute the kind of the data type from the kinds of the
     -- constructor arguments  (mmh, DOES NOT WORK FOR MUTUAL DATA!)
     let newki :: Kind
newki = case ((Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
unionKind Kind
NoKind ((Kinded Constructor -> Kind) -> [Kinded Constructor] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kinded Constructor -> Kind
forall a. Kinded a -> Kind
kindOf [Kinded Constructor]
kcse)) of
          Kind
NoKind  -> Kind
kType -- no non-rec constructor arguments
          Kind
AnyKind -> Kind
AnyKind
          Kind Sort Expr
s Sort Expr
s' -> Sort Expr -> Sort Expr -> Kind
Kind (Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Zero) Sort Expr
s' -- a data type is always also a type
     -- echoKindedTySig newki n dte -- 2012-01-26 disabled (repetitive)

     -- solve for size variables
     Solution
sol <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Solution
forall (m :: * -> *). MonadMeta m => m Solution
solveConstraints
     -- TODO: substitute
     StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadMeta m => m ()
resetConstraints

     -- add destructors only for the constructors that are non-overlapping
     let decls :: [Declaration]
decls = [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> [[Declaration]] -> [Declaration]
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> [Declaration])
-> [ConstructorInfo] -> [[Declaration]]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> [Declaration]
mkDestrs [ConstructorInfo]
cis
         -- cEtaExp = True means that all field names are present
         -- and constructor is not overlapping with others
         mkDestrs :: ConstructorInfo -> [Declaration]
mkDestrs ConstructorInfo
ci | ConstructorInfo -> Bool
cEtaExp ConstructorInfo
ci = [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> [[Declaration]] -> [Declaration]
forall a b. (a -> b) -> a -> b
$ (FieldInfo -> [Declaration]) -> [FieldInfo] -> [[Declaration]]
forall a b. (a -> b) -> [a] -> [b]
map FieldInfo -> [Declaration]
mkDestr (ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci)
                     | Bool
otherwise  = []
         mkDestr :: FieldInfo -> [Declaration]
mkDestr FieldInfo
fi =
          case (FieldInfo -> FieldClass
fClass FieldInfo
fi) of
             Field (Just (Expr
ty, Arity
arity, Clause
cl)) | Bool -> Bool
not (Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased (Dec -> Bool) -> Dec -> Bool
forall a b. (a -> b) -> a -> b
$ FieldInfo -> Dec
fDec FieldInfo
fi) Bool -> Bool -> Bool
&& Bool -> Bool
not (Name -> Bool
emptyName (Name -> Bool) -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ FieldInfo -> Name
fName FieldInfo
fi) ->
               let n' :: Name
n' = FieldInfo -> Name
fName FieldInfo
fi
                   n :: Name
n  = Name -> Name
internal Name
n'
               in
               [Bool -> Co -> [Fun] -> Declaration
MutualFunDecl Bool
False Co
Ind [TySig Expr -> Name -> Arity -> [Clause] -> Fun
Fun (Name -> Expr -> TySig Expr
forall a. Name -> a -> TySig a
TypeSig Name
n Expr
ty) Name
n' Arity
arity [Clause
cl]]]
             FieldClass
_ -> []

     Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Declaration] -> Bool
forall a. Null a => a -> Bool
null [Declaration]
decls)) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"generated destructors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Declaration] -> String
forall a. Show a => a -> String
show [Declaration]
decls
     [[Declaration]]
declse <- (Declaration -> TypeCheck [Declaration])
-> [Declaration]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Declaration]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ d :: Declaration
d@(MutualFunDecl Bool
False Co
co [Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cls]) -> do
                       -- echo $ "G> " ++ showFun co ++ " " ++ show n ++ " : " ++ show t
                       -- echo $ "G> " ++ PP.render (prettyFun n cls)
                       Maybe DefId -> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a.
Maybe DefId
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Maybe DefId -> m a -> m a
checkingMutual Maybe DefId
forall a. Maybe a
Nothing (TypeCheck [Declaration] -> TypeCheck [Declaration])
-> TypeCheck [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ Declaration -> TypeCheck [Declaration]
typeCheckDeclaration Declaration
d)
                 [Declaration]
decls

     -- decide whether to eta-expand at this type
     -- all patterns need to be proper and non-overlapping
     -- at least one constructor needs to be eta-expandable
     let isPatIndFam :: Bool
isPatIndFam = (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ ConstructorInfo
ci -> (PatternsType, [Pattern]) -> PatternsType
forall a b. (a, b) -> a
fst (ConstructorInfo -> (PatternsType, [Pattern])
cPatFam ConstructorInfo
ci) PatternsType -> PatternsType -> Bool
forall a. Eq a => a -> a -> Bool
/= PatternsType
NotPatterns Bool -> Bool -> Bool
&& ConstructorInfo -> Bool
cEtaExp ConstructorInfo
ci) [ConstructorInfo]
cis
--                    && not (or overlapList)
     -- do not eta-expand recursive constructors (might not terminate)
     let disableRec :: ConstructorInfo -> Bool -> ConstructorInfo
disableRec ConstructorInfo
ci {-ov-} Bool
rec' = ConstructorInfo
ci
          { cRec    = rec'
          , cEtaExp =  cEtaExp ci               -- all destructors present
           && fst (cPatFam ci) /= NotPatterns -- proper pattern to compute indices
--           && not ov                          -- non-overlapping
           && not (co==Ind && rec') }         -- non-recursive
     let cis' :: [ConstructorInfo]
cis' = (ConstructorInfo -> Bool -> ConstructorInfo)
-> [ConstructorInfo] -> [Bool] -> [ConstructorInfo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ConstructorInfo -> Bool -> ConstructorInfo
disableRec [ConstructorInfo]
cis {-overlapList-} [Bool]
isRecList
     let typeEtaExpandable :: Bool
typeEtaExpandable = Bool
isPatIndFam Bool -> Bool -> Bool
&& ([ConstructorInfo] -> Bool
forall a. Null a => a -> Bool
null [ConstructorInfo]
cis Bool -> Bool -> Bool
|| (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ConstructorInfo -> Bool
cEtaExp [ConstructorInfo]
cis')
     String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceEtaM (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" eta-expandable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
typeEtaExpandable String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" constructors " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ConstructorInfo] -> String
forall a. Show a => a -> String
show [ConstructorInfo]
cis'
     Name
-> (SigDef -> SigDef)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *).
MonadSig m =>
Name -> (SigDef -> SigDef) -> m ()
modifySig Name
n (\ SigDef
dataSig ->
                      SigDef
dataSig { symbolKind = newki
                              , etaExpand = typeEtaExpandable
                              , constructors = cis'
                              , isTuple = length cis' >= 1 && isPatIndFam
                              })
     -- compute extracted data decl
     let (Telescope
tele, Expr
te) = Int -> Expr -> (Telescope, Expr)
typeToTele' (Telescope -> Int
forall a. Size a => a -> Int
size Telescope
tel) Expr
dte
     [Declaration] -> TypeCheck [Declaration]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> TypeCheck [Declaration])
-> [Declaration] -> TypeCheck [Declaration]
forall a b. (a -> b) -> a -> b
$ (Name
-> Sized
-> Co
-> [Pol]
-> Telescope
-> Expr
-> [Constructor]
-> [Name]
-> Declaration
DataDecl Name
n Sized
sz Co
co [Pol]
pos Telescope
tele Expr
te ((Kinded Constructor -> Constructor)
-> [Kinded Constructor] -> [Constructor]
forall a b. (a -> b) -> [a] -> [b]
map Kinded Constructor -> Constructor
forall a. Kinded a -> a
valueOf [Kinded Constructor]
kcse) [Name]
fields) Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
declse

   ) -- `throwTrace` n  -- in case of an error, add name n to the trace


insertConstructorTele :: Telescope -> Type -> Constructor -> TypeCheck Constructor
insertConstructorTele :: Telescope
-> Expr
-> Constructor
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Constructor
insertConstructorTele Telescope
dtel Expr
dt c :: Constructor
c@(Constructor QName
n Maybe (Telescope, [Pattern])
Nothing Expr
t) = Constructor
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Constructor
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Constructor
c
insertConstructorTele Telescope
dtel Expr
dt c :: Constructor
c@(Constructor QName
n Just{}  Expr
t) = do
  (Telescope, [Pattern])
res <- Telescope -> Expr -> Expr -> TypeCheck (Telescope, [Pattern])
computeConstructorTele Telescope
dtel Expr
dt Expr
t
  Constructor
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Constructor
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constructor
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Constructor)
-> Constructor
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Constructor
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Telescope, [Pattern]) -> Expr -> Constructor
Constructor QName
n ((Telescope, [Pattern]) -> Maybe (Telescope, [Pattern])
forall a. a -> Maybe a
Just (Telescope, [Pattern])
res) Expr
t

-- | @computeConstructorTele dtel t = return ctel@
--   Computes the constructor telescope from the target.
computeConstructorTele :: Telescope -> Type -> Type -> TypeCheck (Telescope, [Pattern])
computeConstructorTele :: Telescope -> Expr -> Expr -> TypeCheck (Telescope, [Pattern])
computeConstructorTele Telescope
dtel Expr
dt Expr
t = do
  -- target is data name applied to parameters and indices
  let (Telescope
_, Expr
target) = Expr -> (Telescope, Expr)
typeToTele Expr
t
      (Expr
_, [Expr]
es)     = Expr -> (Expr, [Expr])
spineView Expr
target
      pars :: [Expr]
pars = Int -> [Expr] -> [Expr]
forall a. Int -> [a] -> [a]
take (Telescope -> Int
forall a. Size a => a -> Int
size Telescope
dtel) [Expr]
es
  (TCContext
cxt, [Pattern]
ps) <- [Expr] -> TVal -> TypeCheck (TCContext, [Pattern])
checkConstructorParams [Expr]
pars  (TVal -> TypeCheck (TCContext, [Pattern]))
-> TypeCheck TVal -> TypeCheck (TCContext, [Pattern])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> TypeCheck TVal
whnf' (Telescope -> Expr -> Expr
teleToType Telescope
dtel Expr
dt)
  (,[Pattern]
ps) (Telescope -> (Telescope, [Pattern]))
-> (Telescope -> Telescope) -> Telescope -> (Telescope, [Pattern])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Telescope -> Telescope
forall a. LensDec a => Dec -> a -> a
setDec (Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
Param) (Telescope -> (Telescope, [Pattern]))
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
-> TypeCheck (Telescope, [Pattern])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do (TCContext -> TCContext)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (TCContext -> TCContext -> TCContext
forall a b. a -> b -> a
const TCContext
cxt) (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
forall a b. (a -> b) -> a -> b
$ TCContext
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
contextToTele TCContext
cxt

-- | @checkConstructorParams pars tv = return cxt@
--   Checks that parameters @pars@ are patterns elimating the datatype @tv@.
--   Returns a context @cxt@ that binds the pattern variables in
--   left-to-right order.
checkConstructorParams :: [Expr] -> TVal -> TypeCheck (TCContext, [Pattern])
checkConstructorParams :: [Expr] -> TVal -> TypeCheck (TCContext, [Pattern])
checkConstructorParams [Expr]
es TVal
tv = do
  -- for now, we only allow patterns in parameters
  -- could be extended to unifyable expressions in general
  [Pattern]
ps <- (Expr
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern)
-> [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Pattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ Expr
e -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> (Pattern
    -> StateT
         TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern)
-> Maybe Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Expr
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall {m :: * -> *} {p} {a}. MonadError TraceError m => p -> m a
errorParamNotPattern Expr
e) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pattern
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern)
-> Maybe Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Pattern
exprToPattern Expr
e) [Expr]
es
  -- no goals from dot patterns, no absurd pattern
  ([],Substitution
_,TCContext
cxt,TVal
_,[Pattern]
_,[TVal]
_,Bool
False) <- Dec
-> [Goal]
-> Substitution
-> TVal
-> [Pattern]
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
checkPatterns Dec
defaultDec [] Substitution
emptySub TVal
tv [Pattern]
ps
  (TCContext, [Pattern]) -> TypeCheck (TCContext, [Pattern])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TCContext
cxt, [Pattern]
ps)

  where
    errorParamNotPattern :: p -> m a
errorParamNotPattern p
e = String -> m a
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$
      String
"expected parameter to be a pattern, but I found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Expr] -> String
forall a. Show a => a -> String
show [Expr]
es

-- |
--   Precondition: @ce@ is included in the current context.
contextToTele :: TCContext -> TypeCheck Telescope
contextToTele :: TCContext
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
contextToTele TCContext
ce = do
  let n     :: Int
      n :: Int
n     = SemCxt -> Int
len (TCContext -> SemCxt
context TCContext
ce)           -- context length
      delta :: Map Int (OneOrTwo Domain)
      delta :: Map Int (OneOrTwo Domain)
delta = SemCxt -> Map Int (OneOrTwo Domain)
cxt (TCContext -> SemCxt
context TCContext
ce)           -- types for dB levels
      names :: Map Int Name
      names :: Map Int Name
names = TCContext -> Map Int Name
naming TCContext
ce                  -- names for dB levels
  -- traverse the context from left to right
  [TBind] -> Telescope
Telescope ([TBind] -> Telescope)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TBind]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    [Int]
-> (Int
    -> StateT
         TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int
  -> StateT
       TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind)
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) [TBind])
-> (Int
    -> StateT
         TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TBind]
forall a b. (a -> b) -> a -> b
$ \ Int
k -> do
      Name
x       <- Int
-> Map Int Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
forall (m :: * -> *) k v.
(MonadError TraceError m, Show k, Ord k) =>
k -> Map k v -> m v
lookupM Int
k Map Int Name
names
      One Domain
dom <- Int
-> Map Int (OneOrTwo Domain)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (OneOrTwo Domain)
forall (m :: * -> *) k v.
(MonadError TraceError m, Show k, Ord k) =>
k -> Map k v -> m v
lookupM Int
k Map Int (OneOrTwo Domain)
delta
      Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Dom Expr -> TBind)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Dom Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> Domain
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Dom Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dom a -> f (Dom b)
Traversable.traverse TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
toExpr Domain
dom

-- | @typeCheckConstructor d dt sz co pols tel (TypeSig c t)@
--
--   returns True if constructor has recursive argument
typeCheckConstructor :: Name -> Type -> Sized -> Co -> [Pol] -> Telescope -> Constructor -> TypeCheck (Bool, Kinded EConstructor)
typeCheckConstructor :: Name
-> Expr
-> Sized
-> Co
-> [Pol]
-> Telescope
-> Constructor
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Bool, Kinded Constructor)
typeCheckConstructor Name
d Expr
dt Sized
sz Co
co [Pol]
pos Telescope
dtel (Constructor QName
n Maybe (Telescope, [Pattern])
mctel Expr
t) = String
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Bool, Kinded Constructor)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Bool, Kinded Constructor)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n) (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Bool, Kinded Constructor)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Bool, Kinded Constructor))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Bool, Kinded Constructor)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Bool, Kinded Constructor)
forall a b. (a -> b) -> a -> b
$ do
  let tel :: Telescope
tel = Telescope
-> ((Telescope, [Pattern]) -> Telescope)
-> Maybe (Telescope, [Pattern])
-> Telescope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Telescope
dtel (Telescope, [Pattern]) -> Telescope
forall a b. (a, b) -> a
fst Maybe (Telescope, [Pattern])
mctel
{-
  tel <- case cpars of
    -- old style data parameters
    Nothing -> return dtel
    -- new style pattern parameters
    Just{}  -> computeConstructorTele dtel dt t
-}
  Signature
sig <- (TCState -> Signature)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Signature
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TCState -> Signature
signature
  let telE :: Telescope
telE = Dec -> Telescope -> Telescope
forall a. LensDec a => Dec -> a -> a
setDec Dec
irrelevantDec Telescope
tel -- need kinded tel!!
    -- parameters are erased in types of constructors
  let tt :: Expr
tt = Telescope -> Expr -> Expr
teleToType Telescope
telE Expr
t
  QName
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *). (Show n, MonadIO m) => n -> Expr -> m ()
echoTySig QName
n Expr
tt
  let params :: Int
params = Telescope -> Int
forall a. Size a => a -> Int
size Telescope
tel
  -- when checking constructor types,  do NOT resurrect telescope
  --   data T [A : Set] : Set { inn : A -> T A }
  -- should be rejected, since A ~= T A, and T A = T B means A ~=B for arb. A, B!
  -- add data name as spos var, to check positivity
  -- and as NoKind, to compute the true kind from the constructors
  let telWithD :: Telescope
telWithD = [TBind] -> Telescope
Telescope ([TBind] -> Telescope) -> [TBind] -> Telescope
forall a b. (a -> b) -> a -> b
$ (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
d (Dom Expr -> TBind) -> Dom Expr -> TBind
forall a b. (a -> b) -> a -> b
$ Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
dt Kind
NoKind (Dec -> Dom Expr) -> Dec -> Dom Expr
forall a b. (a -> b) -> a -> b
$ Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
SPos) TBind -> [TBind] -> [TBind]
forall a. a -> [a] -> [a]
: Telescope -> [TBind]
telescope Telescope
tel
  Kinded Kind
ki Expr
te <- Telescope -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a. Telescope -> TypeCheck a -> TypeCheck a
addBinds Telescope
telWithD (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$
    Sized -> Expr -> TypeCheck (Kinded Expr)
checkConType Sized
sz Expr
t -- do NOT resurrect telescope!!

  -- Check target of constructor.
  TVal
dv <- Expr -> TypeCheck TVal
whnf' Expr
dt
  let (Telescope [TBind]
argts,Expr
target) = Expr -> (Telescope, Expr)
typeToTele Expr
te
  Maybe (Telescope, [Pattern])
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. Monad m => Maybe a -> m () -> m ()
whenNothing Maybe (Telescope, [Pattern])
mctel (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ -- only for old-style parameters
    Telescope
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. Telescope -> TypeCheck a -> TypeCheck a
addBinds Telescope
telWithD (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Telescope
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. Telescope -> TypeCheck a -> TypeCheck a
addBinds ([TBind] -> Telescope
Telescope [TBind]
argts) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Name
-> TVal
-> Telescope
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkTarget Name
d TVal
dv Telescope
tel Expr
target

  -- Make type of a constructor a singleton type.
  let mkName :: a -> Name -> Name
mkName a
i Name
n | Name -> Bool
emptyName Name
n = String -> Name
fresh (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"y" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i
                 | Bool
otherwise   = Name
n
      fields :: [Name]
fields = (TBind -> Name) -> [TBind] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TBind -> Name
forall a. TBinding a -> Name
boundName [TBind]
argts
      argns :: [Name]
argns  = (Integer -> Name -> Name) -> [Integer] -> [Name] -> [Name]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Name -> Name
forall {a}. Show a => a -> Name -> Name
mkName [Integer
0..] ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name]
fields
      argtbs :: [TBind]
argtbs = (Name -> TBind -> TBind) -> [Name] -> [TBind] -> [TBind]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Name
n TBind
tb -> TBind
tb { boundName = n }) [Name]
argns [TBind]
argts
--      core   = (foldl App (con (coToConK co) n) $ map Var argns)
      core :: Expr
core   = RecInfo -> [(Name, Expr)] -> Expr
Record (ConK -> QName -> Bool -> Dotted -> RecInfo
NamedRec (Co -> ConK
coToConK Co
co) QName
n Bool
False Dotted
notDotted) ([(Name, Expr)] -> Expr) -> [(Name, Expr)] -> Expr
forall a b. (a -> b) -> a -> b
$ [Name] -> [Expr] -> [(Name, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fields ([Expr] -> [(Name, Expr)]) -> [Expr] -> [(Name, Expr)]
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> [Name] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Expr
Var [Name]
argns
      tsing :: Expr
tsing  = Telescope -> Expr -> Expr
teleToType ([TBind] -> Telescope
Telescope [TBind]
argtbs) (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
Sing Expr
core Expr
target

  let tte :: Expr
tte = Telescope -> Expr -> Expr
teleToType Telescope
telE Expr
tsing -- te -- DO resurrect here!
  TVal
vt <- Expr -> TypeCheck TVal
whnf' Expr
tte

  -- Now, compute the remaining information concerning the constructor.

  {- old code was more accurate, since it evaluated before checking
     for recursive occurrence.
  recOccs <- sposConstructor d 0 pos vt -- get recursive occurrences
  -}
  [Name]
mutualNames <- (TCContext -> [Name])
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Name]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> [Name]
mutualNames
  let mutOcc :: TBind -> Bool
mutOcc TBind
tb = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Name] -> Bool
forall a. Null a => a -> Bool
null ([Name] -> Bool) -> [Name] -> Bool
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
List.intersect (Name
dName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
mutualNames) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (Expr -> [Name]) -> Expr -> [Name]
forall a b. (a -> b) -> a -> b
$ TBind -> Expr
boundType TBind
tb
      recOccs :: [Bool]
recOccs   = (TBind -> Bool) -> [TBind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TBind -> Bool
mutOcc [TBind]
argts
      isRec :: Bool
isRec     = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
recOccs
  -- fType <- extractType vt -- moved to Extract
  let fType :: Expr
fType = QName -> Expr
undefinedFType QName
n
  Maybe (Name, TVal)
isSz <- if Sized
sz Sized -> Sized -> Bool
forall a. Eq a => a -> a -> Bool
/= Sized
Sized then Maybe (Name, TVal)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Name, TVal))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, TVal)
forall a. Maybe a
Nothing else do
    Name
-> Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szConstructor Name
d Co
co Int
params TVal
vt -- check correct use of sizes
    if Co
co Co -> Co -> Bool
forall a. Eq a => a -> a -> Bool
== Co
CoInd then Maybe (Name, TVal)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Name, TVal))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Name, TVal)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Name, TVal)))
-> Maybe (Name, TVal)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Name, TVal))
forall a b. (a -> b) -> a -> b
$ (Name, TVal) -> Maybe (Name, TVal)
forall a. a -> Maybe a
Just ((Name, TVal) -> Maybe (Name, TVal))
-> (Name, TVal) -> Maybe (Name, TVal)
forall a b. (a -> b) -> a -> b
$ String -> (Name, TVal)
forall a. HasCallStack => String -> a
error String
"impossible lhs type of coconstructor" else do
    let (Name
x, Expr
lte) = (Expr -> Expr) -> (Name, Expr) -> (Name, Expr)
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd (Telescope -> Expr -> Expr
teleToType Telescope
telE) ((Name, Expr) -> (Name, Expr)) -> (Name, Expr) -> (Name, Expr)
forall a b. (a -> b) -> a -> b
$ Int -> Expr -> (Name, Expr)
mkConLType Int
params Expr
te
    Kind
-> QName
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedTySig Kind
kTerm QName
n Expr
lte
    TVal
ltv <- Expr -> TypeCheck TVal
whnf' Expr
lte
    Maybe (Name, TVal)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Name, TVal))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Name, TVal)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Name, TVal)))
-> Maybe (Name, TVal)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Name, TVal))
forall a b. (a -> b) -> a -> b
$ (Name, TVal) -> Maybe (Name, TVal)
forall a. a -> Maybe a
Just (Name
x, TVal
ltv)

  -- Add the type constructor to the signature.
  let cpars :: Maybe ([Name], [Pattern])
cpars = ((Telescope, [Pattern]) -> ([Name], [Pattern]))
-> Maybe (Telescope, [Pattern]) -> Maybe ([Name], [Pattern])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Telescope -> [Name])
-> (Telescope, [Pattern]) -> ([Name], [Pattern])
forall a c d. (a -> c) -> (a, d) -> (c, d)
mapFst ((TBind -> Name) -> [TBind] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TBind -> Name
forall a. TBinding a -> Name
boundName ([TBind] -> [Name])
-> (Telescope -> [TBind]) -> Telescope -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> [TBind]
telescope)) Maybe (Telescope, [Pattern])
mctel -- deletes types, keeps names
  QName
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => QName -> SigDef -> m ()
addSigQ QName
n (Maybe ([Name], [Pattern])
-> Maybe (Name, TVal)
-> [Bool]
-> TVal
-> Name
-> Int
-> Expr
-> SigDef
ConSig Maybe ([Name], [Pattern])
cpars Maybe (Name, TVal)
isSz [Bool]
recOccs TVal
vt Name
d (Telescope -> Int
forall a. Size a => a -> Int
size Telescope
dtel) Expr
fType)
--  let (tele, te) = typeToTele (length tel) tte -- NOT NECESSARY
  Kind
-> QName
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedTySig Kind
kTerm QName
n Expr
tte
  -- traceM ("kind of " ++ n ++ "'s args: " ++ show ki)
--  echoTySigE n tte
  (Bool, Kinded Constructor)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Bool, Kinded Constructor)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isRec, Kind -> Constructor -> Kinded Constructor
forall a. Kind -> a -> Kinded a
Kinded Kind
ki (Constructor -> Kinded Constructor)
-> Constructor -> Kinded Constructor
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Telescope, [Pattern]) -> Expr -> Constructor
Constructor QName
n (((Telescope, [Pattern]) -> (Telescope, [Pattern]))
-> Maybe (Telescope, [Pattern]) -> Maybe (Telescope, [Pattern])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Telescope -> Telescope)
-> (Telescope, [Pattern]) -> (Telescope, [Pattern])
forall a c d. (a -> c) -> (a, d) -> (c, d)
mapFst (Telescope -> Telescope -> Telescope
forall a b. a -> b -> a
const Telescope
telE)) Maybe (Telescope, [Pattern])
mctel) Expr
te)

typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [EFun]
typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [Fun]
typeCheckMeasuredFuns Co
co [Fun]
funs0 = do
    -- echo $ show funs
    [Kinded (TySig Expr)]
kfse <- (Fun
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded (TySig Expr)))
-> [Fun]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded (TySig Expr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Fun
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
typeCheckFunSig [Fun]
funs0 -- NO LONGER erases measure
    -- use erased type signatures with retaines measure
    let funs :: [Fun]
funs = (Kinded (TySig Expr) -> Fun -> Fun)
-> [Kinded (TySig Expr)] -> [Fun] -> [Fun]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (Kinded Kind
ki TySig Expr
ts) Fun
f -> Fun
f { funTypeSig = ts }) [Kinded (TySig Expr)]
kfse [Fun]
funs0

    -- type check and solve size constraints
    -- return clauses with meta vars resolved
    [Kinded [Clause]]
kcle <- Co
-> [Kinded Fun]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
forall a.
Co
-> [Kinded Fun]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Co -> [Kinded Fun] -> m a -> m a
installFuns Co
co ((Kind -> Fun -> Kinded Fun) -> [Kind] -> [Fun] -> [Kinded Fun]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Kind -> Fun -> Kinded Fun
forall a. Kind -> a -> Kinded a
Kinded ((Kinded (TySig Expr) -> Kind) -> [Kinded (TySig Expr)] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kinded (TySig Expr) -> Kind
forall a. Kinded a -> Kind
kindOf [Kinded (TySig Expr)]
kfse) [Fun]
funs) (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   [Kinded [Clause]]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      [Kinded [Clause]])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
forall a b. (a -> b) -> a -> b
$
      (Fun
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> [Fun]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Fun
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
typeCheckFunClauses [Fun]
funs
    let kis :: [Kind]
kis  = (Kinded [Clause] -> Kind) -> [Kinded [Clause]] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kinded [Clause] -> Kind
forall a. Kinded a -> Kind
kindOf [Kinded [Clause]]
kcle
    let clse :: [[Clause]]
clse = (Kinded [Clause] -> [Clause]) -> [Kinded [Clause]] -> [[Clause]]
forall a b. (a -> b) -> [a] -> [b]
map Kinded [Clause] -> [Clause]
forall a. Kinded a -> a
valueOf [Kinded [Clause]]
kcle
{-
    -- replace old clauses by new ones in funs
    let funs' = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clss
-}
    -- get the list of mutually defined function names
    let funse :: [Fun]
funse = (TySig Expr -> Name -> Arity -> [Clause] -> Fun)
-> [TySig Expr] -> [Name] -> [Arity] -> [[Clause]] -> [Fun]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
List.zipWith4 TySig Expr -> Name -> Arity -> [Clause] -> Fun
Fun
                  ((Kinded (TySig Expr) -> TySig Expr)
-> [Kinded (TySig Expr)] -> [TySig Expr]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr -> Expr) -> TySig Expr -> TySig Expr
forall a b. (a -> b) -> TySig a -> TySig b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr -> Expr
eraseMeasure (TySig Expr -> TySig Expr)
-> (Kinded (TySig Expr) -> TySig Expr)
-> Kinded (TySig Expr)
-> TySig Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kinded (TySig Expr) -> TySig Expr
forall a. Kinded a -> a
valueOf) [Kinded (TySig Expr)]
kfse)
                  ((Fun -> Name) -> [Fun] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Fun -> Name
funExtName [Fun]
funs)
                  ((Fun -> Arity) -> [Fun] -> [Arity]
forall a b. (a -> b) -> [a] -> [b]
map Fun -> Arity
funArity [Fun]
funs)
                  [[Clause]]
clse
    -- print reconstructed clauses
    (Fun
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Fun]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cls) -> do
        -- echoR $ n ++ " : " ++ show t
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadIO m => String -> m ()
echoR (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ (Doc -> String
PP.render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Doc
prettyFun Name
n [Clause]
cls))
      [Fun]
funse
    -- replace in signature by erased clauses
    (Kind
 -> Fun
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Kind]
-> [Fun]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Co
-> Kind
-> Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
enableSig Co
co) ((Kind -> Kind -> Kind) -> [Kind] -> [Kind] -> [Kind]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Kind -> Kind -> Kind
intersectKind [Kind]
kis ([Kind] -> [Kind]) -> [Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$ (Kinded (TySig Expr) -> Kind) -> [Kinded (TySig Expr)] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kinded (TySig Expr) -> Kind
forall a. Kinded a -> Kind
kindOf [Kinded (TySig Expr)]
kfse) [Fun]
funse
    [Fun] -> TypeCheck [Fun]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Fun] -> TypeCheck [Fun]) -> [Fun] -> TypeCheck [Fun]
forall a b. (a -> b) -> a -> b
$ [Fun]
funse

  where
    enableSig :: Co -> Kind -> Fun -> TypeCheck ()
    enableSig :: Co
-> Kind
-> Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
enableSig Co
co Kind
ki (Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar' [Clause]
cl') = do
      TVal
vt <- Expr -> TypeCheck TVal
whnf' Expr
t
      Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
n (Co -> TVal -> Kind -> Arity -> [Clause] -> Bool -> Expr -> SigDef
FunSig Co
co TVal
vt Kind
ki Arity
ar' [Clause]
cl' Bool
True (Expr -> SigDef) -> Expr -> SigDef
forall a b. (a -> b) -> a -> b
$ QName -> Expr
undefinedFType (QName -> Expr) -> QName -> Expr
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n)
      -- add a let binding for external use
      TVal
v <- Bool -> TVal -> TVal -> TypeCheck TVal
up Bool
False (Name -> TVal
vFun Name
n) TVal
vt
      Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
n' (TVal -> Kind -> TVal -> Expr -> SigDef
LetSig TVal
vt Kind
ki TVal
v (Expr -> SigDef) -> Expr -> SigDef
forall a b. (a -> b) -> a -> b
$ QName -> Expr
undefinedFType (QName -> Expr) -> QName -> Expr
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n')



-- type check the body of one function in a mutual block
-- type signature is already checked and added to local context
typeCheckFunBody :: Co -> Kind -> Fun -> TypeCheck EFun
typeCheckFunBody :: Co -> Kind -> Fun -> TypeCheck Fun
typeCheckFunBody Co
co Kind
ki0 fun :: Fun
fun@(Fun ts :: TySig Expr
ts@(TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cls0) = do
    -- echo $ show fun
    Co
-> Kinded Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
addFunSig Co
co (Kinded Fun
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> Kinded Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Kind -> Fun -> Kinded Fun
forall a. Kind -> a -> Kinded a
Kinded Kind
ki0 Fun
fun
    -- type check and solve size constraints
    -- return clauses with meta vars resolved
    Kinded Kind
ki [Clause]
clse <- Co
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a.
Co
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Co -> m a -> m a
setCo Co
co (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Kinded [Clause])
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a b. (a -> b) -> a -> b
$ Fun
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
typeCheckFunClauses Fun
fun

    -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary
    -- TODO: proper cleanup, proper removal of admissibility check!
    -- clse <- admCheckFunSig co names ts clse

    -- print reconstructed clauses
    -- echoR $ n ++ " : " ++ show t
    String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadIO m => String -> m ()
echoR (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ (Doc -> String
PP.render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Doc
prettyFun Name
n [Clause]
clse)
    -- replace in signature by erased clauses
    let fune :: Fun
fune = TySig Expr -> Name -> Arity -> [Clause] -> Fun
Fun TySig Expr
ts Name
n' Arity
ar [Clause]
clse
    Kind
-> Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
enableSig Kind
ki Fun
fune
    Fun -> TypeCheck Fun
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Fun
fune


typeCheckFuns :: Co -> [Fun] -> TypeCheck [EFun]
typeCheckFuns :: Co -> [Fun] -> TypeCheck [Fun]
typeCheckFuns Co
co [Fun]
funs0 = do
    -- echo $ show funs
    [Kinded (TySig Expr)]
kfse <- (Fun
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded (TySig Expr)))
-> [Fun]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded (TySig Expr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Fun
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
typeCheckFunSig [Fun]
funs0
    let kfuns :: [Kinded Fun]
kfuns = (Kinded (TySig Expr) -> Fun -> Kinded Fun)
-> [Kinded (TySig Expr)] -> [Fun] -> [Kinded Fun]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (Kinded Kind
ki TySig Expr
ts) (Fun TySig Expr
ts0 Name
n' Arity
ar [Clause]
cls) -> Kind -> Fun -> Kinded Fun
forall a. Kind -> a -> Kinded a
Kinded Kind
ki (TySig Expr -> Name -> Arity -> [Clause] -> Fun
Fun TySig Expr
ts Name
n' Arity
ar [Clause]
cls)) [Kinded (TySig Expr)]
kfse [Fun]
funs0
    -- zipWithM (addFunSig co) (map kindOf kfse) funs
    (Kinded Fun
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Kinded Fun]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Co
-> Kinded Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
addFunSig Co
co) [Kinded Fun]
kfuns
    let funs :: [Fun]
funs = (Kinded Fun -> Fun) -> [Kinded Fun] -> [Fun]
forall a b. (a -> b) -> [a] -> [b]
map Kinded Fun -> Fun
forall a. Kinded a -> a
valueOf [Kinded Fun]
kfuns
    -- type check and solve size constraints
    -- return clauses with meta vars resolved
    [Kinded [Clause]]
kce <- Co
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
forall a.
Co
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Co -> m a -> m a
setCo Co
co (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   [Kinded [Clause]]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      [Kinded [Clause]])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
forall a b. (a -> b) -> a -> b
$ (Fun
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> [Fun]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     [Kinded [Clause]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Fun
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
typeCheckFunClauses [Fun]
funs
    let kis :: [Kind]
kis = (Kinded [Clause] -> Kind) -> [Kinded [Clause]] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kinded [Clause] -> Kind
forall a. Kinded a -> Kind
kindOf [Kinded [Clause]]
kce
    let clse :: [[Clause]]
clse = (Kinded [Clause] -> [Clause]) -> [Kinded [Clause]] -> [[Clause]]
forall a b. (a -> b) -> [a] -> [b]
map Kinded [Clause] -> [Clause]
forall a. Kinded a -> a
valueOf [Kinded [Clause]]
kce
    -- get the list of mutually defined function names
    let names :: [Name]
names   = (Fun -> Name) -> [Fun] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cls) -> Name
n) [Fun]
funs
    -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary
    -- TODO: proper cleanup, proper removal of admissibility check!
    [[Clause]]
clse <- (Fun
 -> [Clause]
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause])
-> [Fun]
-> [[Clause]]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [[Clause]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ (Fun TySig Expr
tysig Name
_ Arity
_ [Clause]
_) [Clause]
cls' -> Co
-> [Name]
-> TySig Expr
-> [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
admCheckFunSig Co
co [Name]
names TySig Expr
tysig [Clause]
cls') [Fun]
funs [[Clause]]
clse
    -- replace old clauses by new ones in funs
    let funse :: [Fun]
funse = (TySig Expr -> Name -> Arity -> [Clause] -> Fun)
-> [TySig Expr] -> [Name] -> [Arity] -> [[Clause]] -> [Fun]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
List.zipWith4 TySig Expr -> Name -> Arity -> [Clause] -> Fun
Fun
                  ((Kinded (TySig Expr) -> TySig Expr)
-> [Kinded (TySig Expr)] -> [TySig Expr]
forall a b. (a -> b) -> [a] -> [b]
map Kinded (TySig Expr) -> TySig Expr
forall a. Kinded a -> a
valueOf [Kinded (TySig Expr)]
kfse)
                  ((Fun -> Name) -> [Fun] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Fun -> Name
funExtName [Fun]
funs)
                  ((Fun -> Arity) -> [Fun] -> [Arity]
forall a b. (a -> b) -> [a] -> [b]
map Fun -> Arity
funArity [Fun]
funs)
                  [[Clause]]
clse
--    let funse = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clse
    -- print reconstructed clauses
    (Fun
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Fun]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cls) -> do
        -- echoR $ n ++ " : " ++ show t
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadIO m => String -> m ()
echoR (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ (Doc -> String
PP.render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Doc
prettyFun Name
n [Clause]
cls))
      [Fun]
funse
    [Fun]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => [Fun] -> m ()
terminationCheck [Fun]
funse
    -- replace in signature by erased clauses
    (Kind
 -> Fun
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Kind]
-> [Fun]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Kind
-> Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
enableSig [Kind]
kis [Fun]
funse
    [Fun] -> TypeCheck [Fun]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Fun] -> TypeCheck [Fun]) -> [Fun] -> TypeCheck [Fun]
forall a b. (a -> b) -> a -> b
$ [Fun]
funse

addFunSig :: Co -> Kinded Fun -> TypeCheck ()
addFunSig :: Co
-> Kinded Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
addFunSig Co
co (Kinded Kind
ki (Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cl)) = do
    Signature
sig <- (TCState -> Signature)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Signature
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TCState -> Signature
signature
    TVal
vt <- Expr -> TypeCheck TVal
whnf' Expr
t -- TODO: PROBLEM for internal extraction (would need te here)
    Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
n (Co -> TVal -> Kind -> Arity -> [Clause] -> Bool -> Expr -> SigDef
FunSig Co
co TVal
vt Kind
ki Arity
ar [Clause]
cl Bool
False (Expr -> SigDef) -> Expr -> SigDef
forall a b. (a -> b) -> a -> b
$ QName -> Expr
undefinedFType (QName -> Expr) -> QName -> Expr
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n) --not yet type checked / termination checked

-- ADMCHECK FOR COFUN is not taking place in checking the lhs
-- TODO: proper analysis for size patterns!
-- admCheckFunSig mutualNames (TypeSig thisName thisType, clauses)
admCheckFunSig :: Co -> [Name] -> TypeSig -> [Clause] -> TypeCheck [Clause]
admCheckFunSig :: Co
-> [Name]
-> TySig Expr
-> [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
admCheckFunSig Co
CoInd  [Name]
mutualNames (TypeSig Name
n Expr
t) [Clause]
cls = [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Clause]
cls
admCheckFunSig co :: Co
co@Co
Ind [Name]
mutualNames (TypeSig Name
n Expr
t) [Clause]
cls = String
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall a. String -> a -> a
traceAdm (String
"admCheckFunSig: checking admissibility of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t) (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause])
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall a b. (a -> b) -> a -> b
$
   (
    do -- a function is not recursive if did does not mention any of the
       -- mutually defined function names
       let usedNames :: [Name]
usedNames = [Clause] -> [Name]
rhsDefs [Clause]
cls
       let notRecursive :: Bool
notRecursive = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ Name
n -> Bool -> Bool
not (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
usedNames)) [Name]
mutualNames
       -- for non-recursive functions, we can skip the admissibility check
       if Bool
notRecursive then
          -- trace ("function " ++ n ++ " is not recursive") $
            [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Clause]
cls
        else -- trace ("function " ++ n ++ " is recursive ") $
          do TVal
vt <- Expr -> TypeCheck TVal
whnf' Expr
t
             Co
-> [Clause]
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
admFunDef Co
co [Clause]
cls TVal
vt
    ) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
-> String
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> String -> m a
`throwTrace` (String
"checking type of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for admissibility")


enableSig :: Kind -> Fun -> TypeCheck ()
enableSig :: Kind
-> Fun
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
enableSig Kind
ki (Fun (TypeSig Name
n Expr
_) Name
n' Arity
ar' [Clause]
cl') = do
  (FunSig Co
co TVal
vt Kind
ki0 Arity
ar [Clause]
cl Bool
_ Expr
ftyp) <- Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => Name -> m SigDef
lookupSymb Name
n
  Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
n (Co -> TVal -> Kind -> Arity -> [Clause] -> Bool -> Expr -> SigDef
FunSig Co
co TVal
vt (Kind -> Kind -> Kind
intersectKind Kind
ki Kind
ki0) Arity
ar [Clause]
cl' Bool
True Expr
ftyp)
  -- add a let binding for external use
  TVal
v <- Bool -> TVal -> TVal -> TypeCheck TVal
up Bool
False (Name -> TVal
vFun Name
n) TVal
vt
  Name
-> SigDef
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadSig m => Name -> SigDef -> m ()
addSig Name
n' (TVal -> Kind -> TVal -> Expr -> SigDef
LetSig TVal
vt Kind
ki TVal
v Expr
ftyp)


-- typeCheckFunSig (TypeSig thisName thisType, clauses)
typeCheckFunSig :: Fun -> TypeCheck (Kinded ETypeSig)
typeCheckFunSig :: Fun
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
typeCheckFunSig (Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cls) = String
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"type of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n) (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Kinded (TySig Expr))
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded (TySig Expr)))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
forall a b. (a -> b) -> a -> b
$ do
  Name
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *). (Show n, MonadIO m) => n -> Expr -> m ()
echoTySig Name
n Expr
t
  Kinded Kind
ki0 Expr
te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
  -- let te = eraseMeasure te0
  let ki :: Kind
ki = Kind -> Kind
predKind Kind
ki0
  Kind
-> Name
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall n (m :: * -> *).
(Show n, MonadIO m) =>
Kind -> n -> Expr -> m ()
echoKindedTySig Kind
ki Name
n (Expr -> Expr
eraseMeasure Expr
te)
--  echoTySigE n te
  Kinded (TySig Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded (TySig Expr)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded (TySig Expr)))
-> Kinded (TySig Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded (TySig Expr))
forall a b. (a -> b) -> a -> b
$ Kind -> TySig Expr -> Kinded (TySig Expr)
forall a. Kind -> a -> Kinded a
Kinded Kind
ki (TySig Expr -> Kinded (TySig Expr))
-> TySig Expr -> Kinded (TySig Expr)
forall a b. (a -> b) -> a -> b
$ Name -> Expr -> TySig Expr
forall a. Name -> a -> TySig a
TypeSig Name
n Expr
te

typeCheckFunClauses :: Fun -> TypeCheck (Kinded [EClause])
typeCheckFunClauses :: Fun
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
typeCheckFunClauses (Fun (TypeSig Name
n Expr
t) Name
n' Arity
ar [Clause]
cl) = String
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (Name -> String
forall a. Show a => a -> String
show Name
n) (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Kinded [Clause])
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a b. (a -> b) -> a -> b
$
   do result :: Kinded [Clause]
result@(Kinded Kind
_ [Clause]
cle) <- Expr
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkFun Expr
t [Clause]
cl
      -- traceCheck (show (TypeSig n t)) $
       -- traceCheck (show cl') $
      -- echo $ PP.render $ prettyFun n cle
      Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kinded [Clause]
result

-- checkConType sz t = Kinded ki te
-- the returned kind is the kind of the constructor arguments
-- check that result is a universe
--  ( params were already checked by checkDataType and are not included in t )
-- called initially in the context consisting of the parameter telescope
checkConType :: Sized -> Expr -> TypeCheck (Kinded Extr)
checkConType :: Sized -> Expr -> TypeCheck (Kinded Expr)
checkConType Sized
NotSized Expr
t = Expr -> TypeCheck (Kinded Expr)
checkConType' Expr
t
checkConType Sized
Sized Expr
t =
    case Expr
t of
      Quant PiSigma
Pi tb :: TBind
tb@(TBind Name
_ (Domain Expr
t1 Kind
_ Dec
_)) Expr
t2 | Expr -> Bool
isSize Expr
t1 -> do
             TBind -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a. TBind -> TypeCheck a -> TypeCheck a
addBind ((Dec -> Dec) -> TBind -> TBind
forall a. LensDec a => (Dec -> Dec) -> a -> a
mapDec (Dec -> Dec -> Dec
forall a b. a -> b -> a
const Dec
paramDec) TBind
tb) (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do  -- size is parametric in constructor type
               Kinded Kind
ki Expr
t2e <- Expr -> TypeCheck (Kinded Expr)
checkConType' Expr
t2
               Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi ((Dec -> Dec) -> TBind -> TBind
forall a. LensDec a => (Dec -> Dec) -> a -> a
mapDec (Dec -> Dec -> Dec
forall a b. a -> b -> a
const Dec
irrelevantDec) TBind
tb) Expr
t2e -- size is irrelevant in constructor
      Expr
_ -> String -> TypeCheck (Kinded Expr)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Kinded Expr))
-> String -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ String
"checkConType: expecting size quantification, found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t

checkConType' :: Expr -> TypeCheck (Kinded Extr)
checkConType' :: Expr -> TypeCheck (Kinded Expr)
checkConType' Expr
t = do
  (Sort TVal
s, Kinded Expr
kte) <- Bool
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a.
Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bool -> m a -> m a
checkingCon Bool
True (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Sort TVal, Kinded Expr)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Sort TVal, Kinded Expr))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t
  case Sort TVal
s of
    Set{} -> Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kinded Expr
kte
    CoSet{} -> Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kinded Expr
kte
    Sort TVal
_ -> String -> TypeCheck (Kinded Expr)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Kinded Expr))
-> String -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ String
"checkConType: type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of constructor not a universe"

-- check that the data type and the parameter arguments (written down like declared in telescope)
-- precondition: target tg type checks in current context
checkTarget :: Name -> TVal -> Telescope -> Type -> TypeCheck ()
checkTarget :: Name
-> TVal
-> Telescope
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkTarget Name
d TVal
dv Telescope
tel Expr
tg = do
  TVal
tv <- Expr -> TypeCheck TVal
whnf' Expr
tg
  case TVal
tv of
    VApp (VDef (DefId IdKind
DatK (QName Name
n))) [TVal]
vs | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
d -> do
      [TVal]
telvs <- (TBind -> TypeCheck TVal)
-> [TBind]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ TBind
tb -> Expr -> TypeCheck TVal
whnf' (Name -> Expr
Var (TBind -> Name
forall a. TBinding a -> Name
boundName TBind
tb))) ([TBind]
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal])
-> [TBind]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
forall a b. (a -> b) -> a -> b
$ Telescope -> [TBind]
telescope Telescope
tel
      OneOrTwo TVal
_ <- String
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (OneOrTwo TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (OneOrTwo TVal)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"checking datatype parameters in constructor target") (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) (OneOrTwo TVal)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (OneOrTwo TVal))
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (OneOrTwo TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (OneOrTwo TVal)
forall a b. (a -> b) -> a -> b
$
        Force
-> Pol
-> OneOrTwo TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (OneOrTwo TVal)
leqVals' Force
N Pol
mixed (TVal -> OneOrTwo TVal
forall a. a -> OneOrTwo a
One TVal
dv) (Int -> [TVal] -> [TVal]
forall a. Int -> [a] -> [a]
take (Telescope -> Int
forall a. Size a => a -> Int
size Telescope
tel) [TVal]
vs) [TVal]
telvs
      () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TVal
_ -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"constructor should produce something in data type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
d

-- check that params are types
-- check that arguments are stypes
-- check that target is set
checkDataType :: Int -> Expr -> TypeCheck (Kinded (Sort Expr, Extr))
checkDataType :: Int -> Expr -> TypeCheck (Kinded (Sort Expr, Expr))
checkDataType Int
p Expr
e = do
  String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"checkDataType " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
p)
  case Expr
e of
     Quant PiSigma
Pi tb :: TBind
tb@(TBind Name
x (Domain Expr
t1 Kind
_ Dec
dec)) Expr
t2 -> do
       Int
k <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
       String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"length of context = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k)
       -- t1e <- checkingDom $ if k <= p then checkType t1 else checkSmallType t1
       (Sort TVal
s1, Kinded Kind
ki0 Expr
t1e) <- StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
checkingDom (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Sort TVal, Kinded Expr)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Sort TVal, Kinded Expr))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t1
       let ki1 :: Kind
ki1 = Kind -> Kind
predKind Kind
ki0
       TBind
-> TypeCheck (Kinded (Sort Expr, Expr))
-> TypeCheck (Kinded (Sort Expr, Expr))
forall a. TBind -> TypeCheck a -> TypeCheck a
addBind (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
t1 Kind
ki1 Dec
defaultDec)) (TypeCheck (Kinded (Sort Expr, Expr))
 -> TypeCheck (Kinded (Sort Expr, Expr)))
-> TypeCheck (Kinded (Sort Expr, Expr))
-> TypeCheck (Kinded (Sort Expr, Expr))
forall a b. (a -> b) -> a -> b
$ do
         Kinded Kind
ki2 (Sort Expr
s, Expr
t2e) <- Int -> Expr -> TypeCheck (Kinded (Sort Expr, Expr))
checkDataType Int
p Expr
t2
         -- when k <= p $ ltSort s1 s -- check size of indices (disabled)
         Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr)))
-> Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr))
forall a b. (a -> b) -> a -> b
$ Kind -> (Sort Expr, Expr) -> Kinded (Sort Expr, Expr)
forall a. Kind -> a -> Kinded a
Kinded Kind
ki2 (Sort Expr
s, PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
t1e Kind
ki1 Dec
dec)) Expr
t2e)
     Sort s :: Sort Expr
s@(Set Expr
e1)   -> do
       (TVal
_, Expr
e1e) <- Expr -> TypeCheck (TVal, Expr)
checkLevel Expr
e1
       Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr)))
-> Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr))
forall a b. (a -> b) -> a -> b
$ Kind -> (Sort Expr, Expr) -> Kinded (Sort Expr, Expr)
forall a. Kind -> a -> Kinded a
Kinded (Expr -> Kind
kUniv Expr
e1e) (Sort Expr
s, Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
e1e)
     Sort s :: Sort Expr
s@(CoSet Expr
e1) -> do
       Expr
e1e <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e1
       Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr)))
-> Kinded (Sort Expr, Expr) -> TypeCheck (Kinded (Sort Expr, Expr))
forall a b. (a -> b) -> a -> b
$ Kind -> (Sort Expr, Expr) -> Kinded (Sort Expr, Expr)
forall a. Kind -> a -> Kinded a
Kinded (Expr -> Kind
kUniv Expr
Zero) (Sort Expr
s, Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Sort Expr
forall a. a -> Sort a
CoSet Expr
e1e)
     Expr
_ -> String -> TypeCheck (Kinded (Sort Expr, Expr))
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
"doesn't target Set or CoSet"

{-
checkSize :: Expr -> TypeCheck Extr
checkSize Infty = return Infty
checkSize e = valueOf <$> checkExpr e vSize
-}

checkSize :: Expr -> TypeCheck Extr
checkSize :: Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e =
  case Expr
e of
    Meta Int
i  -> do
      Ren
ren <- (TCContext -> Ren)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Ren
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> Ren
renaming
      Ren
-> Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadMeta m => Ren -> Int -> m ()
addMeta Ren
ren Int
i
      Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
    Expr
e       -> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
inferSize Expr
e

inferSize :: Expr -> TypeCheck Extr
inferSize :: Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
inferSize Expr
e =
  case Expr
e of
    Expr
Zero  -> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
    Expr
Infty -> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
    Succ Expr
e  -> Expr -> Expr
Succ (Expr -> Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
    Plus [Expr]
es -> [Expr] -> Expr
Plus ([Expr] -> Expr)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize [Expr]
es
    Max  [Expr]
es -> [Expr] -> Expr
maxE ([Expr] -> Expr)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize [Expr]
es
    Expr
e -> do
      (TVal
v, Kinded Kind
ki Expr
e) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e
      TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
subtype TVal
v TVal
vSize
      Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e

checkBelow :: Expr -> LtLe -> Val -> TypeCheck Extr
checkBelow :: Expr
-> LtLe
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkBelow Expr
e LtLe
Le TVal
VInfty = Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
checkBelow Expr
e LtLe
ltle TVal
v = do
  Expr
e' <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
  TVal
v' <- Expr -> TypeCheck TVal
whnf' Expr
e
  LtLe
-> Pol
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
ltle Pol
Pos TVal
v' TVal
v
  Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e'


-- checkLevel e = (value of e, ee)
-- if e : Size and value of e != Infty
checkLevel :: Expr -> TypeCheck (Val, Extr)
checkLevel :: Expr -> TypeCheck (TVal, Expr)
checkLevel Expr
e = do
  Kinded Kind
_ Expr
ee <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e TVal
vSize
  TVal
v  <- Expr -> TypeCheck TVal
whnf' Expr
e
  Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TVal
v TVal -> TVal -> Bool
forall a. Eq a => a -> a -> Bool
== TVal
VInfty) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"# is not a valid universe level"
  (TVal, Expr) -> TypeCheck (TVal, Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
v, Expr
ee)

{- Kind inference

          i    : Size              : Type
      t : Nat  : Set  : Set1 : ... : Type = Set\omega
  p : P : Prop : Set  : ...

Functional, cumulative PTS (s,s',s') written (s,s')

  (Size,s)   s != Size    size-dependency
  (s,Prop)                impredicative Prop
  (Set_i,Set_j)  i <= j   predicativity

Kind    can be used to construct Kinds
term t  terms, types, universes, proofs, propositions
type T  types, universes, propositions
size i  types, universes, propositions
prf  p  proofs
pred P  types, universes, propositions

We like to infer kinds of expressions

  Tm < Set < Set1 < Set2 < ...

For  t : A  if kind(A) = Tm then t is a term,
                       = Set then t is a type,
                       = Set1 then t is a type1 (e.g, a universe) ...

Then,  if  t : (x : A) -> B
      and  kind(A) `irrelevantFor` kind(B)   [ with irrelevantFor := > ]

we can change the type signature to

           t : [x : A] -> B

This is because you cannot eliminate a type to produce a term.

  kind(Set)  = Set
  kind(Size) = Size -- this means that we treat sizes as types, they cannot
  kind(s)    = s    -- if s is a sort
  kind((x : A) -> B) = kind(B)
  kind(A : Set0) = Tm
  kind(A : Prop) = Prf
  kind(A : Size) = <<impossible>>
  kind(A : Setk) = k-1

irrFor Tm  _    = False
irrFor Ty Tm    = True
irrFor Ty Prf   = True
irrFor Ty _     = False
irrFor Size Tm  = True
irrFor Size Prf = True

One problem is that we cannot infer exact kinds, e.g.

  fun T : Bool -> Set 1 -- T is a type
  { T true  = Bool      -- T true is a type
  ; T false = Set 0     -- T false is a universe
  }

T is either a type or a universe.  So we can only assign intervals.
This is like in Augustsson's Cayenne [not in his paper, though].

A datatype is always a type.  A size is a type.
A constructor is always a term.

-}


-- type checking

-- checkExpr e tv = (e', ki)
-- e' is the version of e with erasure marker at irrelevant positions
-- ki is the kind of e (Tm, Ty, Set ...)
-- ki is at most the predecessor of the sort of tv
--
-- this is *internal* extraction in the style of Barras and Bernardo
-- e.g., does not prune t : Id A a b
-- thus, we can use the pruned version for evaluation!
checkExpr :: Expr -> TVal -> TypeCheck (Kinded Extr)
checkExpr :: Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e TVal
v = do
  Int
l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
  StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"checkExpr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |-") StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Expr
e StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall (m :: * -> *). Monad m => m Doc
colon StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v) (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do

   TCContext
ce <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
   String -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a. String -> a -> a
traceCheck (String
"checkExpr: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ren -> String
forall a. Show a => a -> String
show (TCContext -> Ren
renaming TCContext
ce) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SemCxt -> String
forall a. Show a => a -> String
show (TCContext -> SemCxt
context TCContext
ce) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in env" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Env2 -> String
forall a. Show a => a -> String
show (TCContext -> Env2
environ TCContext
ce)) (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do

    (case (Expr
e, TVal
v) of

{- In the presence of full bracket types,
   we could implement the following "resurrecting version of let"

   Gamma |- s : [A]
   Gamma, x:A |- t : C   Gamma, x:A, y:A |- t = t[y/x] : C
   -------------------------------------------------------
   Gamma |- let x:[A] = s in t : C

 -}

      (App (Lam Dec
dec Name
x Expr
f) Expr
e, TVal
v) | Expr -> Bool
inferable Expr
e -> Dec
-> Name
-> Telescope
-> Maybe Expr
-> Expr
-> Expr
-> TVal
-> TypeCheck (Kinded Expr)
checkLet Dec
dec Name
x Telescope
emptyTel Maybe Expr
forall a. Maybe a
Nothing Expr
e Expr
f TVal
v

{-
      (LLet (TBind x (Domain Nothing _ dec)) e1 e2, v) -> checkUntypedLet x dec e1 e2 v
      (LLet (TBind x (Domain (Just t1) _ dec)) e1 e2, v) -> checkTypedLet x t1 dec e1 e2 v
-}
      (LLet (TBind Name
x (Domain Maybe Expr
mt Kind
_ Dec
dec)) Telescope
tel Expr
e1 Expr
e2, TVal
v) -> Dec
-> Name
-> Telescope
-> Maybe Expr
-> Expr
-> Expr
-> TVal
-> TypeCheck (Kinded Expr)
checkLet Dec
dec Name
x Telescope
tel Maybe Expr
mt Expr
e1 Expr
e2 TVal
v

      (Case (Var Name
x) Maybe Expr
Nothing [Clause TeleVal
_ [SuccP (VarP Name
y)] (Just Expr
rhs)], TVal
v) -> do
          (TVal
tv, Kinded Expr
_) <- TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
resurrect (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr (Name -> Expr
Var Name
x)
          TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
subtype TVal
tv TVal
vSize
          vx :: TVal
vx@(VGen Int
i) <- Expr -> TypeCheck TVal
whnf' (Name -> Expr
Var Name
x)
          Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo Int
i TVal
v
          let dom :: Domain
dom = TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
vSize Kind
kSize Dec
defaultDec
          Name
-> Domain
-> (Int -> TVal -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a.
Name
-> Domain
-> (Int
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (Int -> TVal -> m a) -> m a
newWithGen Name
y Domain
dom ((Int -> TVal -> TypeCheck (Kinded Expr))
 -> TypeCheck (Kinded Expr))
-> (Int -> TVal -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ \ Int
j TVal
vy -> do
            let vp :: TVal
vp = TVal -> TVal
VSucc TVal
vy
            Int
-> Int -> Int -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
Int
-> Int
-> Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Int -> Int -> Int -> m a -> m a
addSizeRel Int
j Int
1 Int
i (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$
              Rewrite
-> [TVal]
-> ([TVal] -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a.
Rewrite
-> [TVal]
-> ([TVal]
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Rewrite -> [TVal] -> ([TVal] -> m a) -> m a
addRewrite (TVal -> TVal -> Rewrite
Rewrite TVal
vx TVal
vp) [TVal
v] (([TVal] -> TypeCheck (Kinded Expr)) -> TypeCheck (Kinded Expr))
-> ([TVal] -> TypeCheck (Kinded Expr)) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ \ [TVal
v'] -> do
                Kinded Kind
ki2 Expr
rhse <- Substitution -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkRHS Substitution
emptySub Expr
rhs TVal
v'
                Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki2 (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr -> [Clause] -> Expr
Case (Name -> Expr
Var Name
x) (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
tSize) [TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause [Name -> Domain -> TBinding TVal
forall a. Name -> Dom a -> TBinding a
TBind Name
y Domain
dom] [Pattern -> Pattern
forall e. Pat e -> Pat e
SuccP (Name -> Pattern
forall e. Name -> Pat e
VarP Name
y)] (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
rhse)]


      (Case Expr
e Maybe Expr
mt [Clause]
cs, TVal
v) -> do
          (TVal
tv, Expr
t, Kinded Kind
ki1 Expr
ee) <- Dec -> Expr -> Maybe Expr -> TypeCheck (TVal, Expr, Kinded Expr)
checkOrInfer Dec
neutralDec Expr
e Maybe Expr
mt
          TVal
ve <- Expr -> TypeCheck TVal
whnf' Expr
ee
          -- tv' <- sing' ee tv -- DOES NOT WORK
          Kinded Kind
ki2 [Clause]
cle <- TVal
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkCases TVal
ve (TVal -> TVal -> TVal
arrow TVal
tv TVal
v) [Clause]
cs
          Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki2 (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr -> [Clause] -> Expr
Case Expr
ee (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
t) [Clause]
cle
{-
      (Case e Nothing cs, _) -> do
          (tv, Kinded ki1 ee) <- inferExpr e
          ve <- whnf' ee
          -- tv' <- sing' ee tv -- DOES NOT WORK
          Kinded ki2 cle <- checkCases ve (arrow tv v) cs
          t <- toExpr tv
          return $ Kinded ki2 $ Case ee (Just t) cle
-}
      (Expr
_, VGuard Bound TVal
beta TVal
bv) ->
        Bound TVal -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
Bound TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bound TVal -> m a -> m a
addBoundHyp Bound TVal
beta (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e TVal
bv

      (Expr
e,TVal
v) | Expr -> Bool
inferable Expr
e -> do
          (TVal
v2, Kinded Kind
ki1 Expr
ee) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e
          Expr
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkSubtype Expr
ee TVal
v2 TVal
v
          Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki1 Expr
ee

      (Expr, TVal)
_ -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkForced Expr
e TVal
v

      ) -- >> (trace ("checkExpr successful: " ++ show e ++ ":" ++ show v) $ return ())

-- | checkLet @let .x tel : t = e1 in e2@
checkLet :: Dec -> Name -> Telescope -> Maybe Type -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)
checkLet :: Dec
-> Name
-> Telescope
-> Maybe Expr
-> Expr
-> Expr
-> TVal
-> TypeCheck (Kinded Expr)
checkLet Dec
dec Name
x Telescope
tel Maybe Expr
mt1 Expr
e1 Expr
e2 TVal
v = do
  (TVal
v_t1, Expr
t1e, Kinded Kind
ki1 Expr
e1e) <- Dec
-> Telescope
-> Maybe Expr
-> Expr
-> TypeCheck (TVal, Expr, Kinded Expr)
checkLetDef Dec
dec Telescope
tel Maybe Expr
mt1 Expr
e1
--  (v_t1, t1e, Kinded ki1 e1e) <- checkOrInfer dec e1 mt1
  Name
-> Expr
-> TVal
-> Kind
-> Dec
-> Expr
-> Expr
-> TVal
-> TypeCheck (Kinded Expr)
checkLetBody Name
x Expr
t1e TVal
v_t1 Kind
ki1 Dec
dec Expr
e1e Expr
e2 TVal
v

-- | checkLetDef @.x tel : t = e@ becomes @.x : tel -> t = \ tel -> e@
checkLetDef :: Dec -> Telescope -> Maybe Type -> Expr -> TypeCheck (TVal, EType, Kinded Extr)
checkLetDef :: Dec
-> Telescope
-> Maybe Expr
-> Expr
-> TypeCheck (TVal, Expr, Kinded Expr)
checkLetDef Dec
dec Telescope
tel Maybe Expr
mt Expr
e = (TCContext -> TCContext)
-> TypeCheck (TVal, Expr, Kinded Expr)
-> TypeCheck (TVal, Expr, Kinded Expr)
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ TCContext
cxt -> TCContext
cxt {consistencyCheck = True}) (TypeCheck (TVal, Expr, Kinded Expr)
 -> TypeCheck (TVal, Expr, Kinded Expr))
-> TypeCheck (TVal, Expr, Kinded Expr)
-> TypeCheck (TVal, Expr, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do
  -- 2013-04-01
  -- since a let telescope is treated like a lambda abstraction
  -- and the let-defined symbol reduces by itself, we need to
  -- do the context consistency check at each introduction.
  (Telescope
tel, (TVal
vt, Expr
te, Kinded Kind
ki Expr
ee)) <- Telescope
-> TypeCheck (TVal, Expr, Kinded Expr)
-> TypeCheck (Telescope, (TVal, Expr, Kinded Expr))
forall a. Telescope -> TypeCheck a -> TypeCheck (Telescope, a)
checkTele Telescope
tel (TypeCheck (TVal, Expr, Kinded Expr)
 -> TypeCheck (Telescope, (TVal, Expr, Kinded Expr)))
-> TypeCheck (TVal, Expr, Kinded Expr)
-> TypeCheck (Telescope, (TVal, Expr, Kinded Expr))
forall a b. (a -> b) -> a -> b
$ Dec -> Expr -> Maybe Expr -> TypeCheck (TVal, Expr, Kinded Expr)
checkOrInfer Dec
dec Expr
e Maybe Expr
mt
  Expr
te <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> Expr -> Expr
teleToType Telescope
tel Expr
te
  Expr
ee <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> Expr -> Expr
teleLam Telescope
tel Expr
ee
  TVal
vt <- Expr -> TypeCheck TVal
whnf' Expr
te
  (TVal, Expr, Kinded Expr) -> TypeCheck (TVal, Expr, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
vt, Expr
te, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki Expr
ee)

{-
checkTypedLet :: Name -> Type -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)
checkTypedLet x t1 dec e1 e2 v = do
  Kinded kit t1e <- checkType t1
  v_t1 <- whnf' t1
  Kinded ki0 e1e <- applyDec dec $ checkExpr e1 v_t1
  let ki1 = intersectKind ki0 (predKind kit)
  checkLetBody x t1e v_t1 ki1 dec e1e e2 v
{-
  v_e1 <- whnf' e1
  new x (Domain v_t1 ki1 dec) $ \ vx -> do
    addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do
      Kinded ki2 e2e <- checkExpr e2 v'
      return $ Kinded ki2 $ LLet (TBind x (Domain t1e ki1 dec)) e1e e2e  -- if e2e==Irr then Irr else LLet n t1e e1e e2e
-}

checkUntypedLet :: Name -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)
checkUntypedLet x dec e1 e2 v = do
  (v_t1, Kinded ki1 e1e) <- applyDec dec $ inferExpr e1
  v_e1 <- whnf' e1
  t1e <- toExpr v_t1
  checkLetBody x t1e v_t1 ki1 dec e1e e2 v
-}

checkLetBody :: Name -> EType -> TVal -> Kind -> Dec -> Extr -> Expr -> TVal -> TypeCheck (Kinded Extr)
checkLetBody :: Name
-> Expr
-> TVal
-> Kind
-> Dec
-> Expr
-> Expr
-> TVal
-> TypeCheck (Kinded Expr)
checkLetBody Name
x Expr
t1e TVal
v_t1 Kind
ki1 Dec
dec Expr
e1e Expr
e2 TVal
v = do
  TVal
v_e1 <- Expr -> TypeCheck TVal
whnf' Expr
e1e
  Name
-> Domain
-> (TVal -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a.
Name
-> Domain
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (TVal -> m a) -> m a
new Name
x (TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
v_t1 Kind
ki1 Dec
dec) ((TVal -> TypeCheck (Kinded Expr)) -> TypeCheck (Kinded Expr))
-> (TVal -> TypeCheck (Kinded Expr)) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ \ TVal
vx -> do
    Rewrite
-> [TVal]
-> ([TVal] -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a.
Rewrite
-> [TVal]
-> ([TVal]
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Rewrite -> [TVal] -> ([TVal] -> m a) -> m a
addRewrite (TVal -> TVal -> Rewrite
Rewrite TVal
vx TVal
v_e1) [TVal
v] (([TVal] -> TypeCheck (Kinded Expr)) -> TypeCheck (Kinded Expr))
-> ([TVal] -> TypeCheck (Kinded Expr)) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ \ [TVal
v'] -> do
      Kinded Kind
ki2 Expr
e2e <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e2 TVal
v'
      Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki2 (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ TBinding (Maybe Expr) -> Telescope -> Expr -> Expr -> Expr
LLet (Name -> Dom (Maybe Expr) -> TBinding (Maybe Expr)
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Maybe Expr -> Kind -> Dec -> Dom (Maybe Expr)
forall a. a -> Kind -> Dec -> Dom a
Domain (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
t1e) Kind
ki1 Dec
dec)) Telescope
emptyTel Expr
e1e Expr
e2e
{-
-- Dependent let: not checkable in rho;Delta style
--            v_e1 <- whnf rho e1
--            checkExpr (update rho n v_e1) (v_t1 : delta) e2 v
-}

-- | @checkPair e1 e2 y dom env b@ checks @Pair e1 e2@ against
--   @VQuant Sigma y dom env b@.
checkPair :: Expr -> Expr -> Name -> Domain -> FVal -> TypeCheck (Kinded Expr)
checkPair :: Expr -> Expr -> Name -> Domain -> TVal -> TypeCheck (Kinded Expr)
checkPair Expr
e1 Expr
e2 Name
y dom :: Domain
dom@(Domain TVal
av Kind
ki Dec
dec) TVal
fv = do
  case TVal
av of
    VBelow LtLe
Lt TVal
VInfty -> do
      Bool
lowerSemi <- Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
y Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Int
i TVal
_ TVal
bv -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
lowerSemiCont Int
i TVal
bv
      TVal -> TypeCheck (Kinded Expr)
continue (TVal -> TypeCheck (Kinded Expr))
-> TVal -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ if Bool
lowerSemi then LtLe -> TVal -> TVal
VBelow LtLe
Le TVal
VInfty else TVal
av
    TVal
_ -> TVal -> TypeCheck (Kinded Expr)
continue TVal
av
  where
    continue :: TVal -> TypeCheck (Kinded Expr)
continue TVal
av = do
      Kinded Kind
k1 Expr
e1 <- Dec -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
Dec
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Dec -> m a -> m a
applyDec Dec
dec (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e1 TVal
av
      TVal
v1 <- Expr -> TypeCheck TVal
whnf' Expr
e1
      TVal
bv <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
v1
      Kinded Kind
k2 Expr
e2 <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e2 TVal
bv
      Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (Kind -> Kind -> Kind
unionKind Kind
k1 Kind
k2) (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
Pair (Dec -> Expr -> Expr
forall pol. Polarity pol => pol -> Expr -> Expr
maybeErase Dec
dec Expr
e1) Expr
e2

-- check expression after forcing the type
checkForced :: Expr -> TVal -> TypeCheck (Kinded Expr)
checkForced :: Expr -> TVal -> TypeCheck (Kinded Expr)
checkForced Expr
e TVal
v = do
  Ren
ren <- (TCContext -> Ren)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Ren
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> Ren
renaming
  TVal
v   <- TVal -> TypeCheck TVal
force TVal
v
--  enter ("checkForced " ++ show ren ++ " |- " ++ show e ++ " : " ++ show v) $ do
  StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"checkForced " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ren -> String
forall a. Show a => a -> String
show Ren
ren String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |-") StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Expr
e StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall (m :: * -> *). Monad m => m Doc
colon StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v) (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do
    case (Expr
e,TVal
v) of
{-
      (_, VGuard (Bound (Measure [VGen i]) (Measure [VGen j])) bv) ->
        addSizeRel i j $ checkForced e bv
-}
      (Expr
_, VGuard Bound TVal
beta TVal
bv) ->
        Bound TVal -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
Bound TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bound TVal -> m a -> m a
addBoundHyp Bound TVal
beta (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TVal -> TypeCheck (Kinded Expr)
checkForced Expr
e TVal
bv

      (Pair Expr
e1 Expr
e2, VQuant PiSigma
Sigma Name
y dom :: Domain
dom@(Domain TVal
av Kind
ki Dec
dec) TVal
fv) ->
        Expr -> Expr -> Name -> Domain -> TVal -> TypeCheck (Kinded Expr)
checkPair Expr
e1 Expr
e2 Name
y Domain
dom TVal
fv

      (Record RecInfo
ri [(Name, Expr)]
rs, t :: TVal
t@(VApp (VDef (DefId IdKind
DatK QName
d)) [TVal]
vl)) -> do
         let fail1 :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
fail1 = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"expected" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
t StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"to be a record type")
--         DataSig { numPars, isTuple } <- lookupSymb d
--         unless isTuple $ fail1
         Maybe [(Name, TVal)]
mfs <- QName -> [TVal] -> TypeCheck (Maybe [(Name, TVal)])
getFieldsAtType QName
d [TVal]
vl
         case Maybe [(Name, TVal)]
mfs of
           Maybe [(Name, TVal)]
Nothing -> TypeCheck (Kinded Expr)
forall {a}.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
fail1
           Just [(Name, TVal)]
ptv -> do
             let checkField :: (Name, Expr) -> TypeCheck (Kinded [(Name,Expr)]) -> TypeCheck (Kinded [(Name,Expr)])
                 checkField :: (Name, Expr)
-> TypeCheck (Kinded [(Name, Expr)])
-> TypeCheck (Kinded [(Name, Expr)])
checkField (Name
p,Expr
e) TypeCheck (Kinded [(Name, Expr)])
cont =
                  case Name -> [(Name, TVal)] -> Maybe TVal
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
p [(Name, TVal)]
ptv of
                    Maybe TVal
Nothing -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (Kinded [(Name, Expr)])
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Name
p StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"is not a field of record" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
t)
                    Just TVal
tv -> do
                      TVal
tv <- TVal -> TVal -> TypeCheck TVal
piApp TVal
tv TVal
VIrr -- remove record argument (cannot be dependent!)
                      Kinded Kind
k Expr
e <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e TVal
tv
                      Kinded Kind
k' [(Name, Expr)]
es <- TypeCheck (Kinded [(Name, Expr)])
cont
                      Kinded [(Name, Expr)] -> TypeCheck (Kinded [(Name, Expr)])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded [(Name, Expr)] -> TypeCheck (Kinded [(Name, Expr)]))
-> Kinded [(Name, Expr)] -> TypeCheck (Kinded [(Name, Expr)])
forall a b. (a -> b) -> a -> b
$ Kind -> [(Name, Expr)] -> Kinded [(Name, Expr)]
forall a. Kind -> a -> Kinded a
Kinded (Kind -> Kind -> Kind
unionKind Kind
k Kind
k') ((Name
p,Expr
e) (Name, Expr) -> [(Name, Expr)] -> [(Name, Expr)]
forall a. a -> [a] -> [a]
: [(Name, Expr)]
es)
             Kinded Kind
k [(Name, Expr)]
rs <- ((Name, Expr)
 -> TypeCheck (Kinded [(Name, Expr)])
 -> TypeCheck (Kinded [(Name, Expr)]))
-> TypeCheck (Kinded [(Name, Expr)])
-> [(Name, Expr)]
-> TypeCheck (Kinded [(Name, Expr)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, Expr)
-> TypeCheck (Kinded [(Name, Expr)])
-> TypeCheck (Kinded [(Name, Expr)])
checkField (Kinded [(Name, Expr)] -> TypeCheck (Kinded [(Name, Expr)])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded [(Name, Expr)] -> TypeCheck (Kinded [(Name, Expr)]))
-> Kinded [(Name, Expr)] -> TypeCheck (Kinded [(Name, Expr)])
forall a b. (a -> b) -> a -> b
$ Kind -> [(Name, Expr)] -> Kinded [(Name, Expr)]
forall a. Kind -> a -> Kinded a
Kinded Kind
NoKind []) [(Name, Expr)]
rs
             Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
k (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ RecInfo -> [(Name, Expr)] -> Expr
Record RecInfo
ri [(Name, Expr)]
rs


{- OLD:
Following Awodey/Bauer 2001, the following rule is valid

   Gamma, x:A |- t : B    Gamma, x:A, y:A |- t = t[y/x] : B
   --------------------------------------------------------
   Gamma |- \xt : Pi x:[A]. B

      (Lam _ y e1, VPi dec x va env t1) -> do
          rho <- getEnv  -- get the environment corresponding to Gamma
          new y (Domain va (resurrectDec dec)) $ \ vy -> do
            v_t1 <- whnf (update env x vy) t1
            -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1
            e1e <- checkExpr e1 v_t1
            when (erased dec) $ do  -- now check invariance of the e1
              new y (Domain va (resurrectDec dec)) $ \ vy' -> do
                ve  <- whnf (update rho y vy)  e1e
                ve' <- whnf (update rho y vy') e1e
                eqVal v_t1 ve ve'  -- BUT: ve' does not have type v_t1 !?
            -- prune the lambda if body has been pruned
            return $ if e1e==Irr then Irr else Lam y e1e
 -}

-- NOW just my rule (LICS 2010 draft) a la Barras/Bernardo

      (Lam Dec
_ Name
y Expr
e1, VQuant PiSigma
Pi Name
x Domain
dom TVal
fv) -> do
          -- rho <- getEnv  -- get the environment corresponding to Gamma
          Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
y Domain
dom TVal
fv ((Int -> TVal -> TVal -> TypeCheck (Kinded Expr))
 -> TypeCheck (Kinded Expr))
-> (Int -> TVal -> TVal -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
vy TVal
bv -> do
            -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1
            Kinded Kind
ki1 Expr
e1e <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e1 TVal
bv
            -- the kind of a lambda is the kind of its body
            Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki1 (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Dec -> Name -> Expr -> Expr
Lam (Domain -> Dec
forall a. Dom a -> Dec
decor Domain
dom) Name
y Expr
e1e

      -- lone projection: eta-expand!
      (Proj PrePost
Pre Name
p, VQuant PiSigma
Pi Name
x Domain
dom TVal
fv) -> do
         let y :: Name
y = Name -> String -> Name
nonEmptyName Name
x String
"y"
         Expr -> TVal -> TypeCheck (Kinded Expr)
checkForced (Dec -> Name -> Expr -> Expr
Lam (Domain -> Dec
forall a. Dom a -> Dec
decor Domain
dom) Name
y (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App Expr
e (Name -> Expr
Var Name
y)) TVal
v
{-
      -- should be subsumed by checkBelow:
      (e, v) | isVSize v -> Kinded kSize <$> checkSize e
-}
{-  MOVED to checkSize

      -- metavariables must have type size
      (Meta i, _) | isVSize v -> do
        addMeta ren i
        return $ Kinded kSize $ Meta i

     (Infty, v) | isVSize v -> return $ Kinded kSize $ Infty
      (Zero, v) | isVSize v -> return $ Kinded kSize $ Zero

      (Plus es, v) | isVSize v -> do
              ese <- mapM checkSize es
              return $ Kinded kSize $ Plus ese

      (Max es, v) | isVSize v -> do
              ese <- mapM checkSize es
              return $ Kinded kSize $ Max ese

      (Succ e2, v) | isVSize v -> do
              e2e <- checkSize e2
              return $ Kinded kSize $ Succ e2e
-}

      (Expr
e, VBelow LtLe
ltle TVal
v) -> Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
kSize (Expr -> Kinded Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
-> TypeCheck (Kinded Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr
-> LtLe
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkBelow Expr
e LtLe
ltle TVal
v
{-
              -- prune sizes
              return $ if e2e==Irr then Irr else Succ e2e
-}
      (Expr
e,TVal
v) -> do
        case Expr -> (Expr, [Expr])
spineView Expr
e of

          -- unfold defined patterns
          (h :: Expr
h@(Def (DefId (ConK ConK
DefPat) QName
c)), [Expr]
es) -> do
             PatSig [Name]
xs Pattern
pat TVal
_ <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
c
             let ([Name]
xs1, [Name]
xs2) = Int -> [Name] -> ([Name], [Name])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Expr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
es) [Name]
xs
                 phi :: Name -> Expr
phi Name
x      = Expr -> (Expr -> Expr) -> Maybe Expr -> Expr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Expr
Var Name
x) Expr -> Expr
forall a. a -> a
id (Maybe Expr -> Expr) -> Maybe Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, Expr)] -> Maybe Expr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
x ([Name] -> [Expr] -> [(Name, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
xs1 [Expr]
es)
                 body :: Expr
body       = (Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi (Pattern -> Expr
patternToExpr Pattern
pat)
                 e :: Expr
e          = (Name -> Expr -> Expr) -> Expr -> [Name] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Dec -> Name -> Expr -> Expr
Lam Dec
defaultDec) Expr
body [Name]
xs2
             Expr -> TVal -> TypeCheck (Kinded Expr)
checkForced Expr
e TVal
v

          -- check constructor term
          (h :: Expr
h@(Def (DefId (ConK ConK
co) QName
c)), [Expr]
es) -> ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Expr)
checkConTerm ConK
co QName
c [Expr]
es TVal
v
{-
          (h@(Def (DefId (ConK co) c)), es) -> do
             tv <- conType c v
             (knes, dv) <- checkSpine es tv
             let e = foldl App h $ map (snd . valueOf) knes
             checkSubtype e dv v
             e <- etaExpandPis e dv -- a bit similiar to checkSubtype, which computes a singleton
             return $ Kinded kTerm $ e
-}
          -- else infer
          (Expr, [Expr])
_ -> do
            (TVal
v2,Kinded Expr
kee) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e
            Expr
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkSubtype (Kinded Expr -> Expr
forall a. Kinded a -> a
valueOf Kinded Expr
kee) TVal
v2 TVal
v
            Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kinded Expr
kee

-- | Check (partially applied) constructor term, eta-expand it and turn it
--   into a named record.
checkConTerm :: ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Extr)
checkConTerm :: ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Expr)
checkConTerm ConK
co QName
c [Expr]
es TVal
v = do
  case TVal
v of
    VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> do
      let y :: Name
y = Name -> Name
freshen (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String -> Name
nonEmptyName Name
x String
"y"
      Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
y Domain
dom TVal
fv ((Int -> TVal -> TVal -> TypeCheck (Kinded Expr))
 -> TypeCheck (Kinded Expr))
-> (Int -> TVal -> TVal -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
_ TVal
bv -> do
        Kinded Kind
ki Expr
ee <- ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Expr)
checkConTerm ConK
co QName
c ([Expr]
es [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Name -> Expr
Var Name
y]) TVal
bv
        Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Dec -> Name -> Expr -> Expr
Lam (Domain -> Dec
forall a. Dom a -> Dec
decor Domain
dom) Name
y Expr
ee
    TVal
_ -> do
      QName
c <- QName -> TVal -> TypeCheck QName
disambigCon QName
c TVal
v
      TVal
tv <- QName -> TVal -> TypeCheck TVal
conType QName
c TVal
v
      ([Kinded (Name, Expr)]
knes, TVal
dv) <- [Expr] -> TVal -> TypeCheck ([Kinded (Name, Expr)], TVal)
checkSpine [Expr]
es TVal
tv
      let ee :: Expr
ee = RecInfo -> [(Name, Expr)] -> Expr
Record (ConK -> QName -> Bool -> Dotted -> RecInfo
NamedRec ConK
co QName
c Bool
False Dotted
notDotted) ([(Name, Expr)] -> Expr) -> [(Name, Expr)] -> Expr
forall a b. (a -> b) -> a -> b
$ (Kinded (Name, Expr) -> (Name, Expr))
-> [Kinded (Name, Expr)] -> [(Name, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map Kinded (Name, Expr) -> (Name, Expr)
forall a. Kinded a -> a
valueOf [Kinded (Name, Expr)]
knes
      Expr
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkSubtype Expr
ee TVal
dv TVal
v
      Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Expr -> TypeCheck (Kinded Expr))
-> Kinded Expr -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
kTerm Expr
ee

{-
-- | Check (partially applied) constructor term, eta-expand it and turn it
--   into a named record.
checkConTerm :: ConK -> Name -> [Expr] -> TVal -> TypeCheck (Kinded Extr)
checkConTerm co c es v = do
  tv <- conType c v
  (knes, dv) <- checkSpine es tv
  let e0 = foldl App (Def (DefId (ConK co) c)) $ map (snd . valueOf) knes
  checkSubtype e0 dv v
  (vTel, _) <- telView dv
  let xs   = map (boundName . snd) vTel
      decs = map (decor . boundDom . snd) vTel
      ys   = map freshen xs
      rs   = map valueOf knes ++ (zip xs $ map Var ys)
      e1   = Record (NamedRec co c False) rs
      e    = foldr (uncurry Lam) e1 (zip decs ys)
  return $ Kinded kTerm e
-}

{-
-- | Only eta-expand at function types, do not force.
etaExpandPis :: Expr -> TVal -> TypeCheck Expr
etaExpandPis e tv = do
  case tv of
    VQuant Pi x dom env b -> new x dom $ \ xv -> do
      let y = freshen x
      Lam (decor dom) y <$> do
        etaExpandPis (App e (Var y)) =<< whnf (update env x xv) b
    _ -> return e
-}

checkSpine :: [Expr] -> TVal -> TypeCheck ([Kinded (Name, Extr)], TVal)
checkSpine :: [Expr] -> TVal -> TypeCheck ([Kinded (Name, Expr)], TVal)
checkSpine [] TVal
tv = ([Kinded (Name, Expr)], TVal)
-> TypeCheck ([Kinded (Name, Expr)], TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TVal
tv)
checkSpine (Expr
e : [Expr]
es) TVal
tv = do
  (Kinded (Name, Expr)
kne, TVal
tv) <- Expr -> TVal -> TypeCheck (Kinded (Name, Expr), TVal)
checkApp Expr
e TVal
tv
  ([Kinded (Name, Expr)]
knes, TVal
tv) <- [Expr] -> TVal -> TypeCheck ([Kinded (Name, Expr)], TVal)
checkSpine [Expr]
es TVal
tv
  ([Kinded (Name, Expr)], TVal)
-> TypeCheck ([Kinded (Name, Expr)], TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded (Name, Expr)
kne Kinded (Name, Expr)
-> [Kinded (Name, Expr)] -> [Kinded (Name, Expr)]
forall a. a -> [a] -> [a]
: [Kinded (Name, Expr)]
knes, TVal
tv)

maybeErase :: Polarity pol => pol -> Expr -> Expr
maybeErase :: forall pol. Polarity pol => pol -> Expr -> Expr
maybeErase pol
dec = if pol -> Bool
forall pol. Polarity pol => pol -> Bool
erased pol
dec then Expr -> Expr
erasedExpr else Expr -> Expr
forall a. a -> a
id

-- | checking e against (x : A) -> B returns (x,e) and B[e/x]
checkApp :: Expr -> TVal -> TypeCheck (Kinded (Name, Extr), TVal)
checkApp :: Expr -> TVal -> TypeCheck (Kinded (Name, Expr), TVal)
checkApp Expr
e2 TVal
v = do
  TVal
v <- TVal -> TypeCheck TVal
force TVal
v -- if v is a corecursively defined type in Set, unfold!
  String
-> TypeCheck (Kinded (Name, Expr), TVal)
-> TypeCheck (Kinded (Name, Expr), TVal)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"checkApp " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" eliminated by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e2) (TypeCheck (Kinded (Name, Expr), TVal)
 -> TypeCheck (Kinded (Name, Expr), TVal))
-> TypeCheck (Kinded (Name, Expr), TVal)
-> TypeCheck (Kinded (Name, Expr), TVal)
forall a b. (a -> b) -> a -> b
$ do
  case TVal
v of
    VQuant PiSigma
Pi Name
x dom :: Domain
dom@(Domain av :: TVal
av@(VBelow LtLe
Lt TVal
VInfty) Kind
_ Dec
dec) TVal
fv -> do
      Bool
upperSemi <- Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Int
i TVal
_ TVal
bv -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
upperSemiCont Int
i TVal
bv
      TVal -> TypeCheck (Kinded (Name, Expr), TVal)
continue (TVal -> TypeCheck (Kinded (Name, Expr), TVal))
-> TVal -> TypeCheck (Kinded (Name, Expr), TVal)
forall a b. (a -> b) -> a -> b
$ if Bool
upperSemi then PiSigma -> Name -> Domain -> TVal -> TVal
VQuant PiSigma
Pi Name
x Domain
dom{ typ = VBelow Le VInfty} TVal
fv
                 else TVal
v
    TVal
_ -> TVal -> TypeCheck (Kinded (Name, Expr), TVal)
continue TVal
v
 where
  continue :: TVal -> TypeCheck (Kinded (Name, Expr), TVal)
continue TVal
v = case TVal
v of
    VQuant PiSigma
Pi Name
x (Domain TVal
av Kind
_ Dec
dec) TVal
fv -> do
       (Kind
ki, TVal
v2, Expr
e2e) <- do
         if Expr -> Bool
inferable Expr
e2 then do
       -- if e2 has a singleton type, we should not take v2 = whnf e2
       -- but use the single value of e2
       -- this is against the spirit of bidir. checking
              -- if checking a type we need to resurrect
              (TVal
av', Kinded Kind
ki Expr
e2e) <- Dec
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
Dec
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Dec -> m a -> m a
applyDec Dec
dec (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e2
              case TVal
av' of
                 VSing TVal
v2 TVal
av'' -> do TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
subtype TVal
av' TVal
av
                                     (Kind, TVal, Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kind, TVal, Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
ki, TVal
v2, Expr
e2e)
                 TVal
_ -> do Expr
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkSubtype Expr
e2e TVal
av' TVal
av
                         TVal
v2 <- Expr -> TypeCheck TVal
whnf' Expr
e2e
                         (Kind, TVal, Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kind, TVal, Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
ki, TVal
v2, Expr
e2e)
            else do
              Kinded Kind
ki Expr
e2e <- Dec -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
Dec
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Dec -> m a -> m a
applyDec Dec
dec (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e2 TVal
av
              TVal
v2 <- Expr -> TypeCheck TVal
whnf' Expr
e2e
              (Kind, TVal, Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kind, TVal, Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
ki, TVal
v2, Expr
e2e)
       TVal
bv <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
v2
       -- the kind of the application is the kind of its head
       (Kinded (Name, Expr), TVal)
-> TypeCheck (Kinded (Name, Expr), TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> (Name, Expr) -> Kinded (Name, Expr)
forall a. Kind -> a -> Kinded a
Kinded Kind
ki ((Name, Expr) -> Kinded (Name, Expr))
-> (Name, Expr) -> Kinded (Name, Expr)
forall a b. (a -> b) -> a -> b
$ (Name
x,) (Expr -> (Name, Expr)) -> Expr -> (Name, Expr)
forall a b. (a -> b) -> a -> b
$ Dec -> Expr -> Expr
forall pol. Polarity pol => pol -> Expr -> Expr
maybeErase Dec
dec Expr
e2e, TVal
bv)
       -- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e])
    TVal
_ -> String -> TypeCheck (Kinded (Name, Expr), TVal)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Kinded (Name, Expr), TVal))
-> String -> TypeCheck (Kinded (Name, Expr), TVal)
forall a b. (a -> b) -> a -> b
$ String
"checking application to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": expected function type, found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v


-- checkSubtype  expr : infered_type <= ascribed_type
checkSubtype :: Expr -> TVal -> TVal -> TypeCheck ()
checkSubtype :: Expr
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkSubtype Expr
e TVal
v2 TVal
v = do
    Env
rho <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall (m :: * -> *). MonadCxt m => m Env
getEnv
    String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceSingM (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"computing singleton <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">" -- ++ " in environment " ++ show rho
    TVal
v2principal <- Env -> Expr -> TVal -> TypeCheck TVal
sing Env
rho Expr
e TVal
v2
    String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceSingM (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"subtype checking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v2principal String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ?<= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in environment " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Env -> String
forall a. Show a => a -> String
show Env
rho
    TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
subtype TVal
v2principal TVal
v


-- ptsRule s1 s2 = s  if (s1,s2,s) is a valid rule
-- precondition: s1,s2 are proper sorts, i.e., not Size or Tm
ptsRule :: Bool -> Sort Val -> Sort Val -> TypeCheck (Sort Val)
ptsRule :: Bool -> Sort TVal -> Sort TVal -> TypeCheck (Sort TVal)
ptsRule Bool
er Sort TVal
s1 Sort TVal
s2 = do
  TCContext
cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  let parametric :: Bool
parametric = TCContext -> Bool
checkingConType TCContext
cxt  -- are we dealing with a parametric pi?
  let err :: String
err = String
"ptsRule " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Sort TVal, Sort TVal) -> String
forall a. Show a => a -> String
show (Sort TVal
s1,Sort TVal
s2) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
parametric then String
"(in type of constructor)" else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
  case (Sort TVal
s1,Sort TVal
s2) of
    (Set TVal
VInfty,Sort TVal
_) -> String -> TypeCheck (Sort TVal)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Sort TVal))
-> String -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"domain too big"
    (Set TVal
v1, Set TVal
v2) ->
      if Bool
parametric then do
         Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
er (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Pol
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize Pol
Pos TVal
v1 TVal
v2 -- when we are checking a constructor, to reject
         {- data Bad : Set { bad : Set -> Bad } -}
         Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort TVal
s2
       else Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TypeCheck (Sort TVal))
-> Sort TVal -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ TVal -> Sort TVal
forall a. a -> Sort a
Set (TVal -> Sort TVal) -> TVal -> Sort TVal
forall a b. (a -> b) -> a -> b
$ [TVal] -> TVal
maxSize [TVal
v1,TVal
v2]
    (CoSet TVal
v1, Set TVal
VZero)
       | Bool
parametric   -> Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TypeCheck (Sort TVal))
-> Sort TVal -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ TVal -> Sort TVal
forall a. a -> Sort a
CoSet TVal
v1
       | TVal
v1 TVal -> TVal -> Bool
forall a. Eq a => a -> a -> Bool
== TVal
VInfty -> Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TypeCheck (Sort TVal))
-> Sort TVal -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ TVal -> Sort TVal
forall a. a -> Sort a
Set TVal
VZero
       | Bool
otherwise    -> String -> TypeCheck (Sort TVal)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Sort TVal))
-> String -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"domain cannot be sized"
    (CoSet TVal
v1, CoSet TVal
v2)
       | Bool
parametric   -> do
           let v2' :: TVal
v2' = TVal -> (TVal -> TVal) -> Maybe TVal -> TVal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TVal
v2 TVal -> TVal
forall a. a -> a
id (Maybe TVal -> TVal) -> Maybe TVal -> TVal
forall a b. (a -> b) -> a -> b
$ TVal -> Maybe TVal
predSize TVal
v2
           case TVal -> TVal -> Maybe TVal
minSize TVal
v1 TVal
v2 of
             Just TVal
v  -> Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TypeCheck (Sort TVal))
-> Sort TVal -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ TVal -> Sort TVal
forall a. a -> Sort a
CoSet TVal
v
             Maybe TVal
Nothing -> String -> TypeCheck (Sort TVal)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Sort TVal))
-> String -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"min" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (TVal, TVal) -> String
forall a. Show a => a -> String
show (TVal
v1,TVal
v2) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist"
       | TVal
v1 TVal -> TVal -> Bool
forall a. Eq a => a -> a -> Bool
== TVal
VInfty -> Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TypeCheck (Sort TVal))
-> Sort TVal -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ TVal -> Sort TVal
forall a. a -> Sort a
CoSet (TVal -> Sort TVal) -> TVal -> Sort TVal
forall a b. (a -> b) -> a -> b
$ TVal -> TVal
succSize TVal
v2
       | Bool
otherwise    -> String -> TypeCheck (Sort TVal)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Sort TVal))
-> String -> TypeCheck (Sort TVal)
forall a b. (a -> b) -> a -> b
$ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"domain cannot be sized"
    (Sort TVal, Sort TVal)
_ -> Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort TVal
s2

checkOrInfer :: Dec -> Expr -> Maybe Type -> TypeCheck (TVal, EType, Kinded Extr)
checkOrInfer :: Dec -> Expr -> Maybe Expr -> TypeCheck (TVal, Expr, Kinded Expr)
checkOrInfer Dec
dec Expr
e Maybe Expr
Nothing = do
  (TVal
tv, Kinded Expr
ke) <- Dec
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
Dec
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Dec -> m a -> m a
applyDec Dec
dec (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e
  Expr
te <- TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
toExpr TVal
tv
  (TVal, Expr, Kinded Expr) -> TypeCheck (TVal, Expr, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
tv, Expr
te, Kinded Expr
ke)
checkOrInfer Dec
dec Expr
e (Just Expr
t) = do
  Kinded Kind
kt Expr
te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
  TVal
tv <- Expr -> TypeCheck TVal
whnf' Expr
te
  Kinded Kind
ke Expr
ee <- Dec -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
Dec
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Dec -> m a -> m a
applyDec Dec
dec (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e TVal
tv
  let ki :: Kind
ki = Kind -> Kind -> Kind
intersectKind Kind
ke (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Kind
predKind Kind
kt
  (TVal, Expr, Kinded Expr) -> TypeCheck (TVal, Expr, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TVal, Expr, Kinded Expr) -> TypeCheck (TVal, Expr, Kinded Expr))
-> (TVal, Expr, Kinded Expr) -> TypeCheck (TVal, Expr, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ (TVal
tv, Expr
te, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki Expr
ee)

-- inferType t = (s, te)
inferType :: Expr -> TypeCheck (Sort Val, Kinded Extr)
inferType :: Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t = do
  (TVal
sv, Kinded Expr
te) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
t
  case TVal
sv of
    VSort Sort TVal
s | Bool -> Bool
not (Sort TVal
s Sort TVal -> [Sort TVal] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Class -> Sort TVal) -> [Class] -> [Sort TVal]
forall a b. (a -> b) -> [a] -> [b]
map Class -> Sort TVal
forall a. Class -> Sort a
SortC [Class
Tm,Class
Size]) -> (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal
s,Kinded Expr
te)
    TVal
_ -> String
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Sort TVal, Kinded Expr))
-> String
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ String
"inferExpr: expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to be a type!"

-- inferExpr e = (tv, s, ee)
-- input : expr e | inferable e
-- output: type tv, kind s, and erased form ee of e
-- the kind tells whether e is a term, a size, a set, ...
inferExpr :: Expr -> TypeCheck (TVal, Kinded Extr)
inferExpr :: Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e = do
  (TVal
tv, Kinded Expr
ee) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr' Expr
e
  case TVal
tv of
    VGuard Bound TVal
beta TVal
vb -> do
      Bound TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkGuard Bound TVal
beta
      (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
vb, Kinded Expr
ee)
    TVal
_ -> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
tv, Kinded Expr
ee)

inferProj :: Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Extr)
inferProj :: Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Expr)
inferProj Expr
e1 PrePost
fx Name
p = Bool
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bool -> m a -> m a
checkingCon Bool
False (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do
            (TVal
v, Kinded Kind
ki1 Expr
e1e) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e1
{-
            let fail1 = failDoc (text "expected" <+> prettyTCM e1 <+> text "to be of record type when taking the projection" <+> text p <> comma <+> text "but found type" <+> prettyTCM v)
            let fail2 = failDoc (text "record" <+> prettyTCM e1 <+> text "of type" <+> prettyTCM v <+> text "does not have field" <+> text p)
-}
            TVal
v <- TVal -> TypeCheck TVal
force TVal
v -- if v is a corecursively defined type in Set, unfold!
            TVal
tv <- TVal -> Name -> TVal -> TypeCheck TVal
projectType TVal
v Name
p (TVal -> TypeCheck TVal) -> TypeCheck TVal -> TypeCheck TVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> TypeCheck TVal
whnf' Expr
e1e
            (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
tv, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki1 (Expr -> PrePost -> Name -> Expr
proj Expr
e1e PrePost
fx Name
p))
{-
            case v of
              VApp (VDef (DefId Dat d)) vl -> do
                mfs <- getFieldsAtType d vl
                case mfs of
                  Nothing -> fail1
                  Just ptvs ->
                    case lookup p ptvs of
                      Nothing -> fail2
                      Just tv -> do
                        tv <- piApp tv VIrr -- cut of record arg
                        return (tv, Kinded ki1 (App e1e (Proj p)))
              _ -> fail1
-}


-- inferExpr' might return a VGuard, this is removed in inferExpr
-- the returned kind for constructor type is computed as the union
-- of the kinds of the non-erased arguments
-- otherwise it is the kind of the target
inferExpr' :: Expr -> TypeCheck (TVal, Kinded Extr)
inferExpr' :: Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr' Expr
e = String
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"inferExpr' " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e) (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$
  let returnSing :: Kinded Expr -> TVal -> TypeCheck (TVal, Kinded Expr)
returnSing (Kinded Kind
ki Expr
ee) TVal
tv = do
        TVal
tv' <- Expr -> TVal -> TypeCheck TVal
sing' Expr
ee TVal
tv
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
tv', Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki Expr
ee)
  in
    (case Expr
e of

      Var Name
x -> do
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"infer variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
x)
        CxtEntry1
item <- Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1
forall (m :: * -> *). MonadCxt m => Name -> m CxtEntry1
lookupName1 Name
x
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"infer variable: retrieved item ")
        let dom :: Domain
dom = CxtEntry1 -> Domain
forall a. CxtE a -> a
domain CxtEntry1
item
            av :: TVal
av  = Domain -> TVal
forall a. Dom a -> a
typ Domain
dom
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"infer variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av)
        StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"inferExpr: variable" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Name
x StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall (m :: * -> *). Monad m => m Doc
colon StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
av StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"may not occur") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
          let dec :: Dec
dec  = Domain -> Dec
forall a. Dom a -> Dec
decor Domain
dom
              udec :: UDec
udec = CxtEntry1 -> UDec
forall a. CxtE a -> UDec
upperDec CxtEntry1
item
              pol :: Pol
pol  = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec
              upol :: PProd
upol = UDec -> PProd
forall pol. Polarity pol => Decoration pol -> pol
polarity UDec
udec
          Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec Bool -> Bool -> Bool
&& Bool -> Bool
not (UDec -> Bool
forall pol. Polarity pol => pol -> Bool
erased UDec
udec)) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
            String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail String
", because it is marked as erased"
          String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter String
", because of polarity" (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
            Pol
-> PProd
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqPolM Pol
pol PProd
upol
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"infer variable returns")
        String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"infer variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av)
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ (TVal
av, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (Domain -> Kind
forall a. Dom a -> Kind
kind Domain
dom) (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Name -> Expr
Var Name
x)
{-
        let err = "inferExpr: variable " ++ x ++ " : " ++ show (typ item) ++
                  " may not occur"
        let dec = decor item
        let pol = polarity dec
        if erased dec then
          throwErrorMsg $ err ++ ", because it is marked as erased"
         else if not (leqPol pol SPos) then
          throwErrorMsg $ err ++ ", because it has polarity " ++ show pol
         else do
           -- traceCheckM ("infer variable " ++ x ++ " : " ++ show  (typ item))
           return $ (typ item, Var x) -- TODO: (typ item, kind item, Var x)
-}

      -- for constants, the kind coincides with the type!
      Sort (CoSet Expr
e) -> do
        Expr
ee <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TVal
VSort (TVal -> Sort TVal
forall a. a -> Sort a
Set (TVal -> TVal
VSucc TVal
VZero)), Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (Expr -> Kind
kUniv Expr
Zero) (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Sort Expr
forall a. a -> Sort a
CoSet Expr
ee)
      Sort (Set Expr
e) ->  do
        (TVal
v, Expr
ee) <- Expr -> TypeCheck (TVal, Expr)
checkLevel Expr
e
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TVal
VSort (TVal -> Sort TVal
forall a. a -> Sort a
Set (TVal -> TVal
succSize TVal
v)), Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (Expr -> Kind
kUniv Expr
ee) (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
ee)
      Sort (SortC Class
Size) -> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
vTSize, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
kTSize (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Expr
e)
      Expr
Zero -> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
vSize, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
kSize Expr
Zero)
      Expr
Infty -> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
vSize, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
kSize Expr
Infty)
      Below LtLe
ltle Expr
e -> do
        Expr
ee <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
vTSize, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
kTSize (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ LtLe -> Expr -> Expr
Below LtLe
ltle Expr
ee)

      Quant PiSigma
pisig (TBind Name
n (Domain Expr
t1 Kind
_ Dec
dec)) Expr
t2 -> do
        -- make sure that in a constructor declaration the constructor args are
        -- mixed-variant (there is no subtyping between constrs anyway)
        Bool
checkCon <- (TCContext -> Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> Bool
checkingConType
{- TODO
        when (checkCon && polarity dec /= Mixed) $
          throwErrorMsg $ "constructor arguments must be declared mixed-variant"
-}
        (Sort TVal
s1, Kinded Kind
ki0 Expr
t1e) <- (if PiSigma
pisigPiSigma -> PiSigma -> Bool
forall a. Eq a => a -> a -> Bool
==PiSigma
Pi then StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
checkingDom else StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a. a -> a
id) (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Sort TVal, Kinded Expr)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Sort TVal, Kinded Expr))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$
          Bool
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a.
Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bool -> m a -> m a
checkingCon Bool
False (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Sort TVal, Kinded Expr)
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Sort TVal, Kinded Expr))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t1 -- switch off parametric Pi
        -- the kind of the bound variable is the precedessor of the kind of its type
        let ki1 :: Kind
ki1 = Kind -> Kind
predKind Kind
ki0
        TBind
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a. TBind -> TypeCheck a -> TypeCheck a
addBind (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
n (Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
t1e Kind
ki1 (Dec -> Dom Expr) -> Dec -> Dom Expr
forall a b. (a -> b) -> a -> b
$ Dec
defaultDec)) (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric)
        -- TODO:
        -- addBind (TBind n (Domain t1e ki1 $ coDomainDec dec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric)
          (Sort TVal
s2, Kinded Kind
ki2 Expr
t2e) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t2
          TCContext
ce <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
          let er :: Bool
er = Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec
          Sort TVal
s <- if TCContext -> Bool
impredicative TCContext
ce Bool -> Bool -> Bool
&& Bool
er Bool -> Bool -> Bool
&& Sort TVal
s2 Sort TVal -> Sort TVal -> Bool
forall a. Eq a => a -> a -> Bool
== TVal -> Sort TVal
forall a. a -> Sort a
Set TVal
VZero then Sort TVal -> TypeCheck (Sort TVal)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort TVal
s2 else Bool -> Sort TVal -> Sort TVal -> TypeCheck (Sort TVal)
ptsRule Bool
er Sort TVal
s1 Sort TVal
s2 -- Impredicativity!
          -- improve erasure annotation: irrelevant arguments can be erased!
          let (Kind
ki',Dec
dec') = if Bool
checkCon then
                 -- in case of constructor types the kind is the union
                 -- of the kinds of the constructor arguments
                 if Kind
ki0 Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
kTSize then (Kind
ki2, Dec
irrelevantDec)
                  else if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then (Kind
ki2, Dec
dec) -- do not count erased args in
                 else (Kind -> Kind -> Kind
unionKind Kind
ki0 Kind
ki2, Dec
dec)
                else (Kind
ki2, if Kind -> Kind
argKind Kind
ki0 Kind -> Kind -> Bool
`irrelevantFor` (Kind -> Kind
predKind Kind
ki2)
                            then Dec
irrelevantDec
                            else Dec
dec)
          -- the kind of the Pi-type is the kind of its target (codomain)
          (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TVal
VSort Sort TVal
s, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki' (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
pisig (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
n (Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
t1e Kind
ki1 Dec
dec')) Expr
t2e)

      Quant PiSigma
Pi (TMeasure (Measure [Expr]
mu)) Expr
t2 -> do
        [Expr]
mue <- (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize [Expr]
mu
        (Sort TVal
s, Kinded Kind
ki2 Expr
t2e) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t2
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TVal
VSort Sort TVal
s, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki2 (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi (Measure Expr -> TBind
forall a. Measure Expr -> TBinding a
TMeasure ([Expr] -> Measure Expr
forall a. [a] -> Measure a
Measure [Expr]
mue)) Expr
t2e)

      Quant PiSigma
Pi (TBound (Bound LtLe
ltle (Measure [Expr]
mu) (Measure [Expr]
mu'))) Expr
t2 -> do
        ([Expr]
mue,[Expr]
mue') <- StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  ([Expr], [Expr])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     ([Expr], [Expr])
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
checkingDom (StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   ([Expr], [Expr])
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      ([Expr], [Expr]))
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     ([Expr], [Expr])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     ([Expr], [Expr])
forall a b. (a -> b) -> a -> b
$ do
          [Expr]
mue  <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
checkingDom (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr])
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall a b. (a -> b) -> a -> b
$ (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize [Expr]
mu
          [Expr]
mue' <- (Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> [Expr]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize [Expr]
mu'
          ([Expr], [Expr])
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     ([Expr], [Expr])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Expr]
mue,[Expr]
mue')
        (Sort TVal
s, Kinded Kind
ki2 Expr
t2e) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t2
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TVal
VSort Sort TVal
s, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki2 (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi (Bound Expr -> TBind
forall a. Bound Expr -> TBinding a
TBound (LtLe -> Measure Expr -> Measure Expr -> Bound Expr
forall a. LtLe -> Measure a -> Measure a -> Bound a
Bound LtLe
ltle ([Expr] -> Measure Expr
forall a. [a] -> Measure a
Measure [Expr]
mue) ([Expr] -> Measure Expr
forall a. [a] -> Measure a
Measure [Expr]
mue'))) Expr
t2e)

      Sing Expr
e1 Expr
t -> do
        (Sort TVal
s, Kinded Kind
ki Expr
te) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t
        TVal
tv <- Expr -> TypeCheck TVal
whnf' Expr
te
        Kinded Kind
ki1 Expr
e1e <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e1 TVal
tv
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort TVal -> TVal
VSort (Sort TVal -> TVal) -> Sort TVal -> TVal
forall a b. (a -> b) -> a -> b
$ Sort TVal
s, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (Kind -> Kind -> Kind
intersectKind Kind
ki (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Kind
succKind Kind
ki1) -- not sure how useful the intersection is, maybe just ki is good enough
                             (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
Sing Expr
e1e Expr
te)

{- Not safe to infer pairs because of irrelevance!
      Pair e1 e2 -> do
        (tv1, Kinded k1 e1) <- inferExpr e1
        (tv2, Kinded k2 e2) <- inferExpr e2
        let ki = unionKind k1 k2
            tv = prod tv1 tv2
        return (tv, Kinded ki $ Pair e1 e2)
-}

      App (Proj PrePost
Pre Name
p) Expr
e  -> Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Expr)
inferProj Expr
e PrePost
Pre Name
p
      App Expr
e (Proj PrePost
Post Name
p) -> Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Expr)
inferProj Expr
e PrePost
Post Name
p

      App Expr
e1 Expr
e2 -> Bool
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bool -> m a -> m a
checkingCon Bool
False (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do
        (TVal
v, Kinded Kind
ki1 Expr
e1e) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e1
        (Kinded Kind
ki2 (Name
_, Expr
e2e), TVal
bv) <- Expr -> TVal -> TypeCheck (Kinded (Name, Expr), TVal)
checkApp Expr
e2 TVal
v
        -- the kind of the application is the kind of its head
        (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
bv, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
ki1 (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App Expr
e1e Expr
e2e)
{-
            v <- force v -- if v is a corecursively defined type in Set, unfold!
            case v of
               VQuant Pi x (Domain av _ dec) env b -> do
                  (v2,e2e) <-
                    if inferable e2 then do
                  -- if e2 has a singleton type, we should not take v2 = whnf e2
                  -- but use the single value of e2
                  -- this is against the spirit of bidir. checking
                           -- if checking a type we need to resurrect
                           (av', Kinded _ e2e) <- applyDec dec $ inferExpr e2
                           case av' of
                              VSing v2 av'' -> do subtype av' av
                                                  return (v2,e2e)
                              _ -> do checkSubtype e2e av' av
                                      v2 <- whnf' e2e
                                      return (v2, e2e)
                         else do
                           Kinded _ e2e <- applyDec dec $ checkExpr e2 av
                           v2 <- whnf' e2
                           return (v2, e2e)
                  bv <- whnf (update env x v2) b
                  -- the kind of the application is the kind of its head
                  return (bv, Kinded ki1 $ App e1e (if erased dec then erasedExpr e2e else e2e))
-- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e])
               _ -> throwErrorMsg $ "inferExpr : expected Pi with expression : " ++ show e1 ++ "," ++ show v
-}

--      App e1 (e2:el) -> inferExpr $ (e1 `App` [e2]) `App` el
      -- 2012-01-22 no longer infer constructors
      (Def id :: DefId
id@(DefId {IdKind
idKind :: IdKind
idKind :: DefId -> IdKind
idKind, idName :: DefId -> QName
idName = QName
name})) | Bool -> Bool
not (IdKind -> Bool
conKind IdKind
idKind) -> do -- traceCheckM ("infer defined head " ++ show n)
         Maybe CxtEntry1
mitem <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe CxtEntry1)
forall e (m :: * -> *) a. MonadError e m => m a -> m (Maybe a)
errorToMaybe (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe CxtEntry1))
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe CxtEntry1)
forall a b. (a -> b) -> a -> b
$ Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1
forall (m :: * -> *). MonadCxt m => Name -> m CxtEntry1
lookupName1 (Name
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1)
-> Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1
forall a b. (a -> b) -> a -> b
$ QName -> Name
unqual QName
name
         case Maybe CxtEntry1
mitem of -- first check if it is also a var name
           Just CxtEntry1
item -> do -- we are inside a mutual declaration (not erased!)
             let pol :: Pol
pol  = (Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity (Dec -> Pol) -> Dec -> Pol
forall a b. (a -> b) -> a -> b
$ Domain -> Dec
forall a. Dom a -> Dec
decor (Domain -> Dec) -> Domain -> Dec
forall a b. (a -> b) -> a -> b
$ CxtEntry1 -> Domain
forall a. CxtE a -> a
domain CxtEntry1
item)
             let upol :: PProd
upol = (UDec -> PProd
forall pol. Polarity pol => Decoration pol -> pol
polarity (UDec -> PProd) -> UDec -> PProd
forall a b. (a -> b) -> a -> b
$ CxtEntry1 -> UDec
forall a. CxtE a -> UDec
upperDec CxtEntry1
item)
             Maybe DefId
mId <- (TCContext -> Maybe DefId)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe DefId)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> Maybe DefId
checkingMutualName
             case Maybe DefId
mId of
               Just DefId
srcId ->
                 -- we are checking constructors or function bodies
                 DefId
-> DefId
-> PProd
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
addPosEdge DefId
srcId DefId
id PProd
upol
               Maybe DefId
Nothing ->
                 -- we are checking signatures
                 String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"recursive occurrence of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not strictly positive") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
                   Pol
-> PProd
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqPolM Pol
pol PProd
upol
             (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Domain -> TVal
forall a. Dom a -> a
typ (Domain -> TVal) -> Domain -> TVal
forall a b. (a -> b) -> a -> b
$ CxtEntry1 -> Domain
forall a. CxtE a -> a
domain CxtEntry1
item, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (Domain -> Kind
forall a. Dom a -> Kind
kind (Domain -> Kind) -> Domain -> Kind
forall a b. (a -> b) -> a -> b
$ CxtEntry1 -> Domain
forall a. CxtE a -> a
domain CxtEntry1
item) (Expr -> Kinded Expr) -> Expr -> Kinded Expr
forall a b. (a -> b) -> a -> b
$ Expr
e)
           Maybe CxtEntry1
Nothing -> -- otherwise, it is not the data type name just being defined
                 do SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
name
                    case SigDef
sige of
                      -- data types have always kind Set 0!
                      (DataSig { symbTyp :: SigDef -> TVal
symbTyp = TVal
tv }) -> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
tv, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (SigDef -> Kind
symbolKind SigDef
sige) Expr
e)
                      (FunSig  { symbTyp :: SigDef -> TVal
symbTyp = TVal
tv }) -> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
tv, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (SigDef -> Kind
symbolKind SigDef
sige) Expr
e)
                      -- constructors are always terms
                      (ConSig  { symbTyp :: SigDef -> TVal
symbTyp = TVal
tv }) -> Kinded Expr -> TVal -> TypeCheck (TVal, Kinded Expr)
returnSing (Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded Kind
kTerm Expr
e) TVal
tv  -- constructors have sing.type!
                      (LetSig  { symbTyp :: SigDef -> TVal
symbTyp = TVal
tv }) -> (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal
tv, Kind -> Expr -> Kinded Expr
forall a. Kind -> a -> Kinded a
Kinded (SigDef -> Kind
symbolKind SigDef
sige) Expr
e) -- return $ vSing v tv
{-
      (Con _ n) -> do sig <- gets signature
                      case (lookupSig n sig) of
      (Let n) -> do sig <- gets signature
                    case (lookupSig n sig) of
-}
      Expr
_ -> String -> TypeCheck (TVal, Kinded Expr)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (TVal, Kinded Expr))
-> String -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$ String
"cannot infer type of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e
     ) TypeCheck (TVal, Kinded Expr)
-> ((TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr)
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (TVal, Kinded Expr)
tv -> StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
-> (TCContext -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr)
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ TCContext
ce ->
         String
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a. String -> a -> a
traceCheck (String
"inferExpr: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ren -> String
forall a. Show a => a -> String
show (TCContext -> Ren
renaming TCContext
ce) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SemCxt -> String
forall a. Show a => a -> String
show (TCContext -> SemCxt
context TCContext
ce) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :=> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (TVal, Kinded Expr) -> String
forall a. Show a => a -> String
show (TVal, Kinded Expr)
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in env" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Env2 -> String
forall a. Show a => a -> String
show (TCContext -> Env2
environ TCContext
ce)) (TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr))
-> TypeCheck (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a b. (a -> b) -> a -> b
$
--         traceCheck ("inferExpr: " ++ show e ++ " :=> " ++ show tv) $
           (TVal, Kinded Expr) -> TypeCheck (TVal, Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal, Kinded Expr)
tv


{- BAD IDEA!
improveDec :: Dec -> TVal -> Dec
improveDec dec v = if v == VSet || v == VSize then erased else dec
-}

{-
-- entry point 3: resurrects
checkType :: Expr -> TypeCheck Extr
checkType e = (resurrect $ checkType' e) `throwTrace` ("not a type: " ++ show e )

checkType' :: Expr -> TypeCheck Extr
checkType' e = case e of
    Sort s -> return e
    Pi dec x t1 t2 -> do
        t1e <- checkType' t1
        -- ignore erasure flag in types!
--        t1v <- whnf' t1e
--        new' x (Domain (Dec False) t1v) $ do
        addBind x (Dec False) t1e $ do
          t2e <- checkType' t2
          return $ Pi dec x t1e t2e  -- Pi (improveDec dec t1v) x t1e t2e
    _ -> checkExpr' e $ VSort Set
-}

checkType :: Expr -> TypeCheck (Kinded Extr)
checkType :: Expr -> TypeCheck (Kinded Expr)
checkType Expr
t =
  String -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"not a type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t) (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$
    TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
resurrect (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do
      (Sort TVal
s, Kinded Expr
te) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t
      Pol
-> Sort TVal
-> Sort TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSort Pol
Pos Sort TVal
s (TVal -> Sort TVal
forall a. a -> Sort a
Set TVal
VInfty)
      Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kinded Expr
te

checkSmallType :: Expr -> TypeCheck (Kinded Extr)
checkSmallType :: Expr -> TypeCheck (Kinded Expr)
checkSmallType Expr
t =
  String -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"not a set: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t) (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$
    TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
resurrect (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do
      (Sort TVal
s, Kinded Expr
te) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t
      case Sort TVal
s of
        Set TVal
VZero -> Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kinded Expr
te
        CoSet{} -> Kinded Expr -> TypeCheck (Kinded Expr)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kinded Expr
te
        Sort TVal
_ -> String -> TypeCheck (Kinded Expr)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Kinded Expr))
-> String -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sort TVal -> String
forall a. Show a => a -> String
show Sort TVal
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to be Set or CoSet _"

{-
-- small type
checkSmallType :: Expr -> TypeCheck Extr
checkSmallType e  = (resurrect $ checkExpr' e $ VSort Set) `throwTrace` ("not a set: " ++ show e )
-}

-- check telescope and add bindings to contexts
checkTele :: Telescope -> TypeCheck a -> TypeCheck (ETelescope, a)
checkTele :: forall a. Telescope -> TypeCheck a -> TypeCheck (Telescope, a)
checkTele (Telescope [TBind]
tel) TypeCheck a
k = [TBind] -> TypeCheck (Telescope, a)
loop [TBind]
tel where
  loop :: [TBind] -> TypeCheck (Telescope, a)
loop [TBind]
tel = case [TBind]
tel of
    []                                  -> (Telescope
emptyTel,) (a -> (Telescope, a)) -> TypeCheck a -> TypeCheck (Telescope, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeCheck a
k
    tb :: TBind
tb@(TBind Name
x (Domain Expr
t Kind
_ Dec
dec)) : [TBind]
tel -> do
      Kinded Kind
ki Expr
te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
      let tb :: TBind
tb = Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
te (Kind -> Kind
predKind Kind
ki) Dec
dec)
      (Telescope
tel, a
a) <- TBind -> TypeCheck (Telescope, a) -> TypeCheck (Telescope, a)
forall a. TBind -> TypeCheck a -> TypeCheck a
addBind TBind
tb (TypeCheck (Telescope, a) -> TypeCheck (Telescope, a))
-> TypeCheck (Telescope, a) -> TypeCheck (Telescope, a)
forall a b. (a -> b) -> a -> b
$ [TBind] -> TypeCheck (Telescope, a)
loop [TBind]
tel
      (Telescope, a) -> TypeCheck (Telescope, a)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TBind] -> Telescope
Telescope ([TBind] -> Telescope) -> [TBind] -> Telescope
forall a b. (a -> b) -> a -> b
$ TBind
tb TBind -> [TBind] -> [TBind]
forall a. a -> [a] -> [a]
: Telescope -> [TBind]
telescope Telescope
tel, a
a)

-- the integer argument is the number of the clause, used just for user feedback
checkCases :: Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])
checkCases :: TVal
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkCases = Int
-> TVal
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkCases' Int
1

checkCases' :: Int -> Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])
checkCases' :: Int
-> TVal
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkCases' Int
i TVal
v TVal
tv [] = Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded [Clause]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a b. (a -> b) -> a -> b
$ Kind -> [Clause] -> Kinded [Clause]
forall a. Kind -> a -> Kinded a
Kinded Kind
NoKind []
checkCases' Int
i TVal
v TVal
tv (Clause
c : [Clause]
cl) = do
    Kinded Kind
k1 Clause
ce  <- Int -> TVal -> TVal -> Clause -> TypeCheck (Kinded Clause)
checkCase Int
i TVal
v TVal
tv Clause
c
    Kinded Kind
k2 [Clause]
cle <- Int
-> TVal
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkCases' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TVal
v TVal
tv [Clause]
cl
    Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded [Clause]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a b. (a -> b) -> a -> b
$ Kind -> [Clause] -> Kinded [Clause]
forall a. Kind -> a -> Kinded a
Kinded (Kind -> Kind -> Kind
unionKind Kind
k1 Kind
k2) ([Clause] -> Kinded [Clause]) -> [Clause] -> Kinded [Clause]
forall a b. (a -> b) -> a -> b
$ Clause
ce Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: [Clause]
cle

checkCase :: Int -> Val -> TVal -> Clause -> TypeCheck (Kinded EClause)
checkCase :: Int -> TVal -> TVal -> Clause -> TypeCheck (Kinded Clause)
checkCase Int
i TVal
v TVal
tv cl :: Clause
cl@(Clause TeleVal
_ [Pattern
p] Maybe Expr
mrhs) = String -> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) (TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause))
-> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$
  -- traceCheck ("checking case " ++ show i) $
    do
      -- clearDots -- NOT NEEDED
      ([Goal]
flex,Substitution
ins,TCContext
cxt,TVal
vt,Pattern
pe,TVal
pv,Bool
absp) <- Dec
-> [Goal]
-> Substitution
-> TVal
-> Pattern
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
checkPattern Dec
forall pol. Polarity pol => pol
neutral [] Substitution
emptySub TVal
tv Pattern
p
      (TCContext -> TCContext)
-> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ TCContext
_ -> TCContext
cxt) (TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause))
-> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ do
        (Goal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Goal]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Substitution
-> Goal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkGoal Substitution
ins) [Goal]
flex
        TeleVal
tel <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TeleVal
forall (m :: * -> *). MonadCxt m => m TeleVal
getContextTele -- TODO!
        case (Bool
absp,Maybe Expr
mrhs) of
           (Bool
True,Maybe Expr
Nothing) -> Kinded Clause -> TypeCheck (Kinded Clause)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Clause -> TypeCheck (Kinded Clause))
-> Kinded Clause -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ Kind -> Clause -> Kinded Clause
forall a. Kind -> a -> Kinded a
Kinded Kind
NoKind (TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
tel [Pattern
pe] Maybe Expr
forall a. Maybe a
Nothing)
           (Bool
False,Maybe Expr
Nothing) -> String -> TypeCheck (Kinded Clause)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"missing right hand side in case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Clause -> String
showCase Clause
cl)
           (Bool
True,Just Expr
rhs) -> String -> TypeCheck (Kinded Clause)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"absurd pattern requires no right hand side in case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Clause -> String
showCase Clause
cl)
           (Bool
False,Just Expr
rhs) -> do
              -- pv <- whnf' (patternToExpr p) -- DIFFICULT FOR DOT PATTERNS!
      --        vp <- patternToVal p -- BUG: INTRODUCES FRESH GENS, BUT THEY HAVE ALREADY BEEN INTRODUCED IN checkPattern
              Rewrite
-> [TVal]
-> ([TVal] -> TypeCheck (Kinded Clause))
-> TypeCheck (Kinded Clause)
forall a.
Rewrite
-> [TVal]
-> ([TVal]
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Rewrite -> [TVal] -> ([TVal] -> m a) -> m a
addRewrite (TVal -> TVal -> Rewrite
Rewrite TVal
v TVal
pv) [TVal
vt] (([TVal] -> TypeCheck (Kinded Clause))
 -> TypeCheck (Kinded Clause))
-> ([TVal] -> TypeCheck (Kinded Clause))
-> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ \ [TVal
vt'] -> do
                Kinded Kind
ki Expr
rhse <- Substitution -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkRHS Substitution
ins Expr
rhs TVal
vt'
                Kinded Clause -> TypeCheck (Kinded Clause)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Clause -> TypeCheck (Kinded Clause))
-> Kinded Clause -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ Kind -> Clause -> Kinded Clause
forall a. Kind -> a -> Kinded a
Kinded Kind
ki (TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
tel [Pattern
pe] (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
rhse))
                -- [rhs'] <- solveAndModify [rhs] (environ cxt)
                -- return (Clause [p] rhs')

-- type check a function

checkFun :: Type -> [Clause] -> TypeCheck (Kinded [EClause])
checkFun :: Expr
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkFun Expr
t [Clause]
cl = do
  TVal
tv <- Expr -> TypeCheck TVal
whnf' Expr
t
  TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkClauses TVal
tv [Clause]
cl

-- the integer argument is the number of the clause, used just for user feedback
checkClauses :: TVal -> [Clause] -> TypeCheck (Kinded [EClause])
checkClauses :: TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkClauses = Int
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkClauses' Int
1

checkClauses' :: Int -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])
checkClauses' :: Int
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkClauses' Int
i TVal
tv [] = Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded [Clause]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a b. (a -> b) -> a -> b
$ Kind -> [Clause] -> Kinded [Clause]
forall a. Kind -> a -> Kinded a
Kinded Kind
NoKind ([])
checkClauses' Int
i TVal
tv (Clause
c:[Clause]
cl) = do
    Kinded Kind
ki1 Clause
ce  <- Int -> TVal -> Clause -> TypeCheck (Kinded Clause)
checkClause Int
i TVal
tv Clause
c
    Kinded Kind
ki2 [Clause]
cle <- Int
-> TVal
-> [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
checkClauses' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TVal
tv [Clause]
cl
    Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded [Clause]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Kinded [Clause]))
-> Kinded [Clause]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Kinded [Clause])
forall a b. (a -> b) -> a -> b
$ Kind -> [Clause] -> Kinded [Clause]
forall a. Kind -> a -> Kinded a
Kinded (Kind -> Kind -> Kind
unionKind Kind
ki1 Kind
ki2) ([Clause] -> Kinded [Clause]) -> [Clause] -> Kinded [Clause]
forall a b. (a -> b) -> a -> b
$ (Clause
ce Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: [Clause]
cle)

-- checkClause i tv cl = (cl', cle)
-- checking one equation cl of a function at type tv
-- solve size constraints
-- substitute solution into clause, resulting in cl'
-- return also extracted clause cle
checkClause :: Int -> TVal -> Clause -> TypeCheck (Kinded EClause)
checkClause :: Int -> TVal -> Clause -> TypeCheck (Kinded Clause)
checkClause Int
i TVal
tv cl :: Clause
cl@(Clause TeleVal
_ [Pattern]
pl Maybe Expr
mrhs) = String -> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"clause " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) (TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause))
-> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ do
  -- traceCheck ("checking function clause " ++ show i) $
    -- clearDots -- NOT NEEDED
    ([Goal]
flex,Substitution
ins,TCContext
cxt,TVal
tv0,[Pattern]
ple,[TVal]
plv,Bool
absp) <- Dec
-> [Goal]
-> Substitution
-> TVal
-> [Pattern]
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
checkPatterns Dec
forall pol. Polarity pol => pol
neutral [] Substitution
emptySub TVal
tv [Pattern]
pl
    -- 2013-03-30 When checking the rhs, we only allow new size hypotheses
    -- if they do not break any valuation of the existing hypotheses.
    -- See ICFP 2013 paper.
    -- We exclude cofuns here, for experimentation.
    -- Note that cofuns need not be SN, so the strict consistency may be
    -- not necessary.
    (TCContext -> TCContext)
-> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ TCContext
_ -> TCContext
cxt { consistencyCheck = (mutualCo cxt == Ind) }) (TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause))
-> TypeCheck (Kinded Clause) -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ do
      (Goal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Goal]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Substitution
-> Goal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkGoal Substitution
ins) [Goal]
flex
{-
      dots <- openDots
      unless (null dots) $
        recoverFailDoc $ text "the following dotted constructors could not be confirmed: " <+> prettyTCM dots
-}
      -- TODO: insert meta var solution in dot patterns
      TeleVal
tel <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TeleVal
forall (m :: * -> *). MonadCxt m => m TeleVal
getContextTele -- WRONG TELE, has VGens for DotPs
      case (Bool
absp,Maybe Expr
mrhs) of
         (Bool
True,Maybe Expr
Nothing) -> Kinded Clause -> TypeCheck (Kinded Clause)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Clause -> TypeCheck (Kinded Clause))
-> Kinded Clause -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ Kind -> Clause -> Kinded Clause
forall a. Kind -> a -> Kinded a
Kinded Kind
NoKind (TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
tel [Pattern]
ple Maybe Expr
forall a. Maybe a
Nothing)
         (Bool
False,Maybe Expr
Nothing) -> String -> TypeCheck (Kinded Clause)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"missing right hand side in clause " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Clause -> String
forall a. Show a => a -> String
show Clause
cl)
         (Bool
True,Just Expr
rhs) -> String -> TypeCheck (Kinded Clause)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"absurd pattern requires no right hand side in clause " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Clause -> String
forall a. Show a => a -> String
show Clause
cl)
         (Bool
False,Just Expr
rhs) -> do
            Kinded Kind
ki Expr
rhse <- Substitution -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkRHS Substitution
ins Expr
rhs TVal
tv0
            Env
env  <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall (m :: * -> *). MonadCxt m => m Env
getEnv
            [Expr
rhse] <- [Expr]
-> Env
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall (m :: * -> *). MonadMeta m => [Expr] -> Env -> m [Expr]
solveAndModify [Expr
rhse] Env
env
            Kinded Clause -> TypeCheck (Kinded Clause)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kinded Clause -> TypeCheck (Kinded Clause))
-> Kinded Clause -> TypeCheck (Kinded Clause)
forall a b. (a -> b) -> a -> b
$ Kind -> Clause -> Kinded Clause
forall a. Kind -> a -> Kinded a
Kinded Kind
ki (TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
tel [Pattern]
ple (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
rhse))


-- * Pattern checking ------------------------------------------------

type Substitution = Valuation -- [(Int,Val)]

emptySub :: Substitution
emptySub :: Substitution
emptySub = Substitution
emptyVal

sgSub :: Int -> Val -> Substitution
sgSub :: Int -> TVal -> Substitution
sgSub = Int -> TVal -> Substitution
sgVal

lookupSub :: Int -> Substitution -> Maybe Val
lookupSub :: Int -> Substitution -> Maybe TVal
lookupSub Int
i = Int -> [(Int, TVal)] -> Maybe TVal
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i ([(Int, TVal)] -> Maybe TVal)
-> (Substitution -> [(Int, TVal)]) -> Substitution -> Maybe TVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution -> [(Int, TVal)]
valuation

type DotFlex = (Int,(Expr,Domain))

-- left over goals
data Goal
    = DotFlex Int (Maybe Expr) Domain
      -- ^ @Just@ : Flexible variable from inaccessible pattern.
      -- ^ @Nothing@ : Flexible variable from hidden function type.
    | MaxMatches Int TVal
    | DottedCons Dotted Pattern TVal
  deriving Int -> Goal -> String -> String
[Goal] -> String -> String
Goal -> String
(Int -> Goal -> String -> String)
-> (Goal -> String) -> ([Goal] -> String -> String) -> Show Goal
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Goal -> String -> String
showsPrec :: Int -> Goal -> String -> String
$cshow :: Goal -> String
show :: Goal -> String
$cshowList :: [Goal] -> String -> String
showList :: [Goal] -> String -> String
Show

-- checkPatterns is initially called with an empty local context
-- in the type checking monad
checkPatterns :: Dec -> [Goal] -> Substitution -> TVal -> [Pattern] -> TypeCheck ([Goal],Substitution,TCContext,TVal,[EPattern],[Val],Bool)
checkPatterns :: Dec
-> [Goal]
-> Substitution
-> TVal
-> [Pattern]
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
checkPatterns Dec
dec0 [Goal]
flex Substitution
ins TVal
v [Pattern]
pl =
  case TVal
v of
    VMeasured Measure TVal
mu TVal
vb -> Measure TVal
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a.
Measure TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Measure TVal -> m a -> m a
setMeasure Measure TVal
mu (TypeCheck
   ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
 -> TypeCheck
      ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool))
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a b. (a -> b) -> a -> b
$ Dec
-> [Goal]
-> Substitution
-> TVal
-> [Pattern]
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
checkPatterns Dec
dec0 [Goal]
flex Substitution
ins TVal
vb [Pattern]
pl
    VGuard Bound TVal
beta TVal
vb -> Bound TVal
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a.
Bound TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bound TVal -> m a -> m a
addBoundHyp Bound TVal
beta (TypeCheck
   ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
 -> TypeCheck
      ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool))
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a b. (a -> b) -> a -> b
$ Dec
-> [Goal]
-> Substitution
-> TVal
-> [Pattern]
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
checkPatterns Dec
dec0 [Goal]
flex Substitution
ins TVal
vb [Pattern]
pl
{-
    VGuard beta vb -> throwErrorMsg $ "checkPattern at type " ++ show v ++ " --- introduction of constraints not supported"
-}
    TVal
_ -> case [Pattern]
pl of
      [] -> do TCContext
cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
               ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex,Substitution
ins,TCContext
cxt,TVal
v,[],[],Bool
False)
      (Pattern
p:[Pattern]
pl') -> do ([Goal]
flex',Substitution
ins',TCContext
cxt',TVal
v',Pattern
pe,TVal
pv,Bool
absp) <- Dec
-> [Goal]
-> Substitution
-> TVal
-> Pattern
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
checkPattern Dec
dec0 [Goal]
flex Substitution
ins TVal
v Pattern
p
                    (TCContext -> TCContext)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ TCContext
_ -> TCContext
cxt') (TypeCheck
   ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
 -> TypeCheck
      ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool))
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a b. (a -> b) -> a -> b
$ do
                      ([Goal]
flex'',Substitution
ins'',TCContext
cxt'',TVal
v'',[Pattern]
ple,[TVal]
plv,Bool
absps) <- Dec
-> [Goal]
-> Substitution
-> TVal
-> [Pattern]
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
checkPatterns Dec
dec0 [Goal]
flex' Substitution
ins' TVal
v' [Pattern]
pl'
                      ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex'',Substitution
ins'',TCContext
cxt'',TVal
v'', Pattern
pePattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
:[Pattern]
ple, TVal
pvTVal -> [TVal] -> [TVal]
forall a. a -> [a] -> [a]
:[TVal]
plv, Bool
absp Bool -> Bool -> Bool
|| Bool
absps) -- if pe==IrrP then ple else pe:ple)

{-
checkPattern dec0 flex subst tv p = (flex', subst', cxt', tv', pe, pv, absp)

Input :
  dec0  : context in which pattern occurs (irrelevant, parametric, recursive)
          are we checking an erased argument? (constr. pat. needs to be forced!)
  flex  : list of pairs (flexible variable, its dot pattern + supposed type)
  subst : list of pairs (flexible variable, its valuation)
  cxt   : in monad, containing
    rho   : binding of variables to values
    delta : binding of generic values to their types
  tv    : type of the expression \ p -> t
  p     : the pattern to check

Output
  tv'   : type of t
  pe    : erased pattern
  pv    : value of pattern (this is in essence whnf' pe,
            but we cannot evaluate because of dot patterns)
  absp  : did we encounter an absurd pattern
-}

checkPattern :: Dec -> [Goal] -> Substitution -> TVal -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,TVal,EPattern,Val,Bool)
checkPattern :: Dec
-> [Goal]
-> Substitution
-> TVal
-> Pattern
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
checkPattern Dec
dec0 [Goal]
flex Substitution
ins TVal
tv Pattern
p = -- ask >>= \ TCContext { context = delta, environ = rho } -> trace ("checkPattern" ++ ("\n  dot pats: " +?+ show flex) ++ ("\n  substion: " +?+ show ins) ++ ("\n  environ : " +?+ show rho) ++ ("\n  context : " +?+ show delta) ++ "\n  pattern : " ++ show p ++ "\n  at type : " ++ show tv ++ "\t<>") $
 String
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p) (TypeCheck
   ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
 -> TypeCheck
      ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool))
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$ do
  TVal
tv <- TVal -> TypeCheck TVal
force TVal
tv
  case TVal
tv of
    -- record type can be eliminated
    VApp (VDef (DefId IdKind
DatK QName
d)) [TVal]
vl ->
      case Pattern
p of
        ProjP Name
proj -> do
          TVal
tv <- TVal -> Name -> TVal -> TypeCheck TVal
projectType TVal
tv Name
proj TVal
VIrr -- do not have record value here
          TCContext
cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
          ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex, Substitution
ins, TCContext
cxt, TVal
tv, Pattern
p, PrePost -> Name -> TVal
VProj PrePost
Post Name
proj, Bool
False)
{-
          mfs <- getFieldsAtType d vl
          case mfs of
            Nothing -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with projection pattern" <+> prettyTCM p)
            Just ptvs ->
              case lookup proj ptvs of
                Nothing -> failDoc (text "record type" <+> prettyTCM tv <+> text "does not know projection" <+> text proj)
                Just tv -> do
                  tv <- piApp tv VIrr -- cut of record arg
                  cxt <- ask
                  return (flex, ins, cxt, tv, p, VProj proj, False)
-}
        Pattern
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"cannot eliminate type" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"with a non-projection pattern")

    -- intersection type
    VQuant PiSigma
Pi Name
x dom :: Domain
dom@(Domain TVal
av Kind
ki Dec
Hidden) TVal
fv -> do
      -- introduce new flexible variable
      Name
-> Domain
-> (Int
    -> TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool))
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall a.
Name
-> Domain
-> (Int
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (Int -> TVal -> m a) -> m a
newWithGen Name
x Domain
dom ((Int
  -> TVal
  -> TypeCheck
       ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool))
 -> TypeCheck
      ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool))
-> (Int
    -> TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool))
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$ \ Int
i TVal
xv -> do
        TVal
tv <- TVal
fv TVal -> TVal -> TypeCheck TVal
`app` TVal
xv
        Dec
-> [Goal]
-> Substitution
-> TVal
-> Pattern
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
checkPattern Dec
dec0 (Int -> Maybe Expr -> Domain -> Goal
DotFlex Int
i Maybe Expr
forall a. Maybe a
Nothing Domain
dom Goal -> [Goal] -> [Goal]
forall a. a -> [a] -> [a]
: [Goal]
flex) Substitution
ins TVal
tv Pattern
p

    -- function type can be eliminated
    VQuant PiSigma
Pi Name
x (Domain TVal
av Kind
ki Dec
dec) TVal
fv -> do
{-
       let erased' = er || erased dec
       let decEr   = if erased' then irrelevantDec else dec -- dec {erased = erased'}
-}
       let decEr :: Dec
decEr = Dec
dec Dec -> Dec -> Dec
forall pol. Polarity pol => pol -> pol -> pol
`compose` Dec
dec0
       let domEr :: Domain
domEr   =  (TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
av Kind
ki Dec
decEr)
       case Pattern
p of

         -- treat successor pattern here, because of admissibility check
         SuccP Pattern
p2 -> do
                 Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TVal
av TVal -> TVal -> Bool
forall a. Eq a => a -> a -> Bool
/= TVal
vSize) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
"checkPattern: expected type Size"
                 Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Pattern -> Bool
isSuccessorPattern Pattern
p2) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Pattern
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
cannotMatchDeep Pattern
p TVal
tv

                 Co
co <- (TCContext -> Co)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Co
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> Co
mutualCo
                 Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Co
co Co -> Co -> Bool
forall a. Eq a => a -> a -> Bool
/= Co
CoInd) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
                   String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"successor pattern only allowed in cofun")

                 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"checkPattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" : matching on size, checking that target") StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"ends in correct coinductive sized type") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
                   Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
domEr TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
i TVal
_ TVal
bv -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo Int
i TVal
bv

                 TCContext
cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
                 -- 2012-02-05 assume size variable in SuccP to be < #
                 let sucTy :: TVal
sucTy = (TVal
vFinSize TVal -> TVal -> TVal
`arrow` TVal
vFinSize)
                 ([Goal]
flex',Substitution
ins',TCContext
cxt',TVal
tv',Pattern
p2e,TVal
p2v,Bool
absp) <- Dec
-> [Goal]
-> Substitution
-> TVal
-> Pattern
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
checkPattern Dec
decEr [Goal]
flex Substitution
ins TVal
sucTy Pattern
p2
                 -- leqVal Mixed delta' VSet VSize av -- av = VSize
                 let pe :: Pattern
pe = Pattern -> Pattern
forall e. Pat e -> Pat e
SuccP Pattern
p2e
                 let pv :: TVal
pv = TVal -> TVal
VSucc TVal
p2v
--                 pv0 <- local (\ _ -> cxt') $ whnf' $ patternToExpr pe
                 -- pv0 <- patternToVal p -- RETIRE patternToVal
                 -- pv  <- up False pv0 av -- STUPID what can be eta-exanded at type Size??
                 TVal
vb  <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
pv
{-
                 endsInCoind <- endsInSizedCo pv vb
                 when (not endsInCoind) $ throwErrorMsg $ "checkPattern " ++ show p ++" : cannot match on size since target " ++ show tv ++ " does not end in correct coinductive sized type"
-}
                 ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex',Substitution
ins',TCContext
cxt',TVal
vb,Pattern
pe,TVal
pv,Bool
absp)

         -- other patterns: no need to know about result type
         Pattern
_ -> do
           ([Goal]
flex',Substitution
ins',TCContext
cxt',Pattern
pe,TVal
pv,Bool
absp) <- [Goal]
-> Substitution
-> Domain
-> Pattern
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
checkPattern' [Goal]
flex Substitution
ins Domain
domEr Pattern
p
           -- traceM ("checkPattern' returns " ++ show (flex',ins',cxt',pe,pv,absp))
           TVal
vb  <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
pv
           TVal
vb  <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
ins' TVal
vb  -- from ConP case -- ?? why not first subst and then whnf?
           -- traceCheckM ("Returning type " ++ show vb)
           ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex',Substitution
ins',TCContext
cxt',TVal
vb,Pattern
pe,TVal
pv,Bool
absp)

    TVal
_ -> String
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> TypeCheck
      ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool))
-> String
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$ String
"checkPattern: expected function type, found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv

-- TODO: refactor with monad transformers
-- put absp into writer monad

turnIntoVarPatAtUnitType :: TVal -> Pattern -> TypeCheck Pattern
turnIntoVarPatAtUnitType :: TVal
-> Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
turnIntoVarPatAtUnitType (VApp (VDef (DefId IdKind
DatK QName
n)) [TVal]
_) p :: Pattern
p@(ConP PatternInfo
pi QName
c []) =
  (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a b. (a -> b) -> a -> b
$ QName
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
isUnitData QName
n) (Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
p) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a b. (a -> b) -> a -> b
$ do
    let x :: Name
x = String -> Name
fresh String
"un!t"
    Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern)
-> Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a b. (a -> b) -> a -> b
$ Name -> Pattern
forall e. Name -> Pat e
VarP Name
x
turnIntoVarPatAtUnitType TVal
_ Pattern
p = Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
p

checkPattern' :: [Goal] -> Substitution -> Domain -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,EPattern,Val,Bool)
checkPattern' :: [Goal]
-> Substitution
-> Domain
-> Pattern
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
checkPattern' [Goal]
flex Substitution
ins domEr :: Domain
domEr@(Domain TVal
av Kind
ki Dec
decEr) Pattern
p = do
       Pattern
p <- TVal
-> Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
turnIntoVarPatAtUnitType TVal
av Pattern
p
       case Pattern
p of
          SuccP{} -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"successor pattern" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Pattern
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Pattern
p StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"not allowed here")

          PairP Pattern
p1 Pattern
p2 -> do
            TVal
av <- TVal -> TypeCheck TVal
force TVal
av
            case TVal
av of
             VQuant PiSigma
Sigma Name
y dom1 :: Domain
dom1@(Domain TVal
av1 Kind
ki1 Dec
dec1) TVal
fv -> do
              ([Goal]
flex, Substitution
ins, TCContext
cxt, Pattern
pe1, TVal
pv1, Bool
absp1) <-
                 [Goal]
-> Substitution
-> Domain
-> Pattern
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
checkPattern' [Goal]
flex Substitution
ins (TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
av1 Kind
ki1 (Dec -> Domain) -> Dec -> Domain
forall a b. (a -> b) -> a -> b
$ Dec
dec1 Dec -> Dec -> Dec
forall pol. Polarity pol => pol -> pol -> pol
`compose` Dec
decEr) Pattern
p1
              TVal
av2 <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
pv1
              ([Goal]
flex, Substitution
ins, TCContext
cxt, Pattern
pe2, TVal
pv2, Bool
absp2) <-
                 (TCContext -> TCContext)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (TCContext -> TCContext -> TCContext
forall a b. a -> b -> a
const TCContext
cxt) (TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
 -> TypeCheck
      ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$
                   [Goal]
-> Substitution
-> Domain
-> Pattern
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
checkPattern' [Goal]
flex Substitution
ins (TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
av2 Kind
ki Dec
decEr) Pattern
p2
              ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex, Substitution
ins, TCContext
cxt, Pattern -> Pattern -> Pattern
forall e. Pat e -> Pat e -> Pat e
PairP Pattern
pe1 Pattern
pe2, TVal -> TVal -> TVal
VPair TVal
pv1 TVal
pv2, Bool
absp1 Bool -> Bool -> Bool
|| Bool
absp2)
             TVal
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"pair pattern" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Pattern
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Pattern
p StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"could not be checked against type" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
av)
{-
   (x : Sigma y:A. B) -> C
     =iso= (y : A) -> (x' : B) -> C[(y,x')/x]

   (x : Sigma y:V. <B;rho1>) -> <C;rho2>
     =iso= (y : V) -> <(x': B) -> C; ?? x=(y,x')>
 -}
{-
            case av of
              VQuant Sigma y dom1@(Domain av1 ki1 dec1) env1 a2 -> do
                let x' = x ++ "#2"
                    ep = Pair (Var y) (Var x')
                    tv = VQuant Pi y dom1 env1 $
                           Quant x' (Domain a2
-}

          ProjP Name
proj -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"cannot eliminate type" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
av StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"with projection pattern" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Pattern
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Pattern
p)

          VarP Name
y -> do
            Name
-> Domain
-> (TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
Name
-> Domain
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (TVal -> m a) -> m a
new Name
y Domain
domEr ((TVal
  -> TypeCheck
       ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
 -> TypeCheck
      ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> (TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$ \ TVal
xv -> do
              TCContext
cxt' <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
              Pattern
p' <- case TVal
av of
                       VBelow LtLe
Lt TVal
v -> (Expr -> Name -> Pattern) -> Name -> Expr -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr -> Name -> Pattern
forall e. e -> Name -> Pat e
SizeP Name
y (Expr -> Pattern)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
toExpr TVal
v
                       TVal
_ -> Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
p
              ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex, Substitution
ins, TCContext
cxt', Pattern -> Pattern
forall e. Pat e -> Pat e
maybeErase (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Pattern
p', TVal
xv, Bool
False)

{- checking bounded size patterns

    ex : [i : Size] -> [j : Below< i] -> ...
    ex i (j < i) = ...

  type of pattern : Below< i needs to cover type of parameter Below< i

    zero : [j : Size] -> Nat $j   -- need to hold a "sized con type"
    zero : [j < i]    -> Nat i

    ex : [i : Size] -> (n : Nat i) -> ...
    ex i (zero (j < i) = ...

  type of size-pat : Below< i

-}
          SizeP Expr
e Name
y -> do -- pattern (z > y), y is the bound variable, z the bound of z
            Expr
e <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
resurrect (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall a b. (a -> b) -> a -> b
$ Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e -- (Var z)
            Name
-> Domain
-> (Int
    -> TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
Name
-> Domain
-> (Int
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (Int -> TVal -> m a) -> m a
newWithGen Name
y Domain
domEr ((Int
  -> TVal
  -> TypeCheck
       ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
 -> TypeCheck
      ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> (Int
    -> TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$ \ Int
j TVal
xv -> do
{-
               VGen k <- whnf' (Var z)
               addSizeRel j 1 k $ do  -- j < k
-}
               TVal
ve <- Expr -> TypeCheck TVal
whnf' Expr
e
               Bound TVal
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
Bound TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bound TVal -> m a -> m a
addBoundHyp (LtLe -> Measure TVal -> Measure TVal -> Bound TVal
forall a. LtLe -> Measure a -> Measure a -> Bound a
Bound LtLe
Lt ([TVal] -> Measure TVal
forall a. [a] -> Measure a
Measure [TVal
xv]) ([TVal] -> Measure TVal
forall a. [a] -> Measure a
Measure [TVal
ve])) (TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
 -> TypeCheck
      ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$ do
                 TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
subtype TVal
av (LtLe -> TVal -> TVal
VBelow LtLe
Lt TVal
ve)
                 TCContext
cxt' <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
                 ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex, Substitution
ins, TCContext
cxt', Pattern -> Pattern
forall e. Pat e -> Pat e
maybeErase (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Expr -> Name -> Pattern
forall e. e -> Name -> Pat e
SizeP Expr
e Name
y, TVal
xv, Bool
False)

          Pattern
AbsurdP -> do
                 Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TVal -> Bool
isFunType TVal
av) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"absurd pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not match function types, like " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av)
                 TCContext
cxt' <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
                 ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> TVal -> Goal
MaxMatches Int
0 TVal
av Goal -> [Goal] -> [Goal]
forall a. a -> [a] -> [a]
: [Goal]
flex, Substitution
ins, TCContext
cxt', Pattern -> Pattern
forall e. Pat e -> Pat e
maybeErase (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Pattern
forall e. Pat e
AbsurdP, TVal
VIrr, Bool
True)
{-
                 cenvs <- matchingConstructors av  -- TODO: av might be MVar
                                                   -- need to be postponed
                 case cenvs of
                    [] -> do bv   <- whnf (update env x VIrr) b
                             cxt' <- ask
                             return (flex, ins, cxt', bv, maybeErase $ AbsurdP, True)
                    _ -> throwErrorMsg $ "type " ++ show av ++ " of absurd pattern not empty"
-}

          -- always expand defined patterns!
          p :: Pattern
p@(ConP PatternInfo
pi QName
n [Pattern]
ps) | PatternInfo -> ConK
coPat PatternInfo
pi ConK -> ConK -> Bool
forall a. Eq a => a -> a -> Bool
== ConK
DefPat -> do
            [Goal]
-> Substitution
-> Domain
-> Pattern
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
checkPattern' [Goal]
flex Substitution
ins Domain
domEr (Pattern
 -> TypeCheck
      ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
expandDefPat Pattern
p

--          ConP pi n pl | not $ dottedPat pi -> do
          ConP PatternInfo
pi QName
n [Pattern]
pl -> do

                 -- disambiguate constructor first
                 QName
n <- QName -> TVal -> TypeCheck QName
disambigCon QName
n TVal
av

                 let co :: ConK
co     = PatternInfo -> ConK
coPat PatternInfo
pi
                     dotted :: Bool
dotted = PatternInfo -> Bool
dottedPat PatternInfo
pi

                 -- First check that we do not match against an irrelevant argument.
                 Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dotted (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ QName
-> ConK
-> [Pattern]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
nonDottedConstructorChecks QName
n ConK
co [Pattern]
pl
{- TODO
                 enter ("can only match non parametric arguments") $
                   leqPolM (polarity dec) (pprod defaultPol)
-}
                 (TVal
vc,([Goal]
flex',Substitution
ins',TCContext
cxt',TVal
vc',[Pattern]
ple,[TVal]
pvs,Bool
absp)) <- ConK
-> QName
-> [Pattern]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (TVal,
      ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool))
checkConstructorPattern ConK
co QName
n [Pattern]
pl

                 Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TVal -> Bool
isFunType TVal
vc') (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"higher-order matching of pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
vc' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not allowed")
                 let flexgen :: [Int]
flexgen = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Goal -> [Int]) -> [Goal] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (\ Goal
g -> case Goal
g of
                        DotFlex Int
i Maybe Expr
_ Domain
_ -> [Int
i]
                        Goal
_ -> []) [Goal]
flex'
                     -- fst $ unzip flex'
--                  av1 <- sing (environ cxt') (patternToExpr p) vc'
--                  av2 <- sing (environ cxt') (patternToExpr p) av
--                  subst <- local (\ _ -> cxt') $ inst flexgen VSet av1 av2


                 -- need to evaluate the erased pattern!
                 let pe :: Pattern
pe = PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP PatternInfo
pi QName
n [Pattern]
ple -- erased pattern
                 -- dot <- if dottedPat pi then newDotted p else return notDotted
                 Dotted
dot <- if PatternInfo -> Bool
dottedPat PatternInfo
pi then Bool
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Dotted
forall (m :: * -> *). MonadIO m => Bool -> m Dotted
mkDotted Bool
True else Dotted
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Dotted
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Dotted
notDotted
                 TVal
pv0 <- Dotted -> ConK -> QName -> [TVal] -> TVal -> TypeCheck TVal
mkConVal Dotted
dot ConK
co QName
n [TVal]
pvs TVal
vc
                 -- OLD: let pv0 = VDef (DefId (ConK co) n) `VApp` pvs
{-
                 let epe = patternToExpr pe
                 pv0 <- local (\ _ -> cxt') $ whnf' epe
--                 pv0 <- patternToVal p -- THIS USE should be ok, since the new GENs are not in the global context yet, only in cxt' -- NO LONGER ok with erasure!
                 -- traceM $ "sucessfully computed value " ++ show pv0 ++ " of pattern " ++ show epe
-}

                 Substitution
subst <- (TCContext -> TCContext)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ TCContext
_ -> TCContext
cxt') (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b. (a -> b) -> a -> b
$ do
                   case TVal
av of  -- TODO: need subtyping-unify instead of unify??
                     VSing TVal
vav TVal
av0 -> do
                       TVal
vav <- TVal -> TypeCheck TVal
whnfClos TVal
vav
                       Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
Pos [Int]
flexgen TVal
av0 TVal
pv0 TVal
vav
                     TVal
_ -> [Int]
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
unifyIndices [Int]
flexgen TVal
vc' TVal
av  -- vc' <= av ?!
                   -- THIS IMPLEMENTATION RELIES HEAVILY ON INJECTIVITY OF DATAS

{- moved to checkRHS
                 -- apply substitution to measures in environment
                 let mmu = (envBound . environ) cxt'
                 mmu' <- Traversable.mapM (substitute subst) mmu
-}
{-
                 ins'' <- compSubst ins' subst
                 vb <- substitute ins'' vb
                 delta' <- substitute ins'' delta'
-}
                 Substitution
ins''   <- Substitution
-> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
compSubst Substitution
ins' Substitution
subst -- 2010-07-27 not ok to switch!
                 SemCxt
delta'' <- Substitution -> SemCxt -> TypeCheck SemCxt
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
ins'' (TCContext -> SemCxt
context TCContext
cxt')
                 String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"delta'' = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SemCxt -> String
forall a. Show a => a -> String
show SemCxt
delta''
                 TVal
av  <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
ins'' TVal
av  -- 2010-09-22: update av
                 TVal
pv  <- Bool -> TVal -> TVal -> TypeCheck TVal
up Bool
False TVal
pv0 TVal
av

                 -- if the constructor was dotted, make sure it is the only match
                 let flex'' :: [Goal]
flex'' = Bool -> ([Goal] -> [Goal]) -> [Goal] -> [Goal]
forall a. Bool -> (a -> a) -> a -> a
fwhen Bool
dotted (Dotted -> Pattern -> TVal -> Goal
DottedCons Dotted
dot Pattern
p TVal
av Goal -> [Goal] -> [Goal]
forall a. a -> [a] -> [a]
:) [Goal]
flex'
                 ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Goal]
flex'', Substitution
ins'', TCContext
cxt' { context = delta'' },
                         Pattern -> Pattern
forall e. Pat e -> Pat e
maybeErase Pattern
pe, TVal
pv, Bool
absp)
{- DO NOT UPDATE measure here, its done in checkRHS
                 return (flex', ins'', cxt' { context = delta'', environ = (environ cxt') { envBound = mmu' } }, vb',
                         maybeErase pe, absp)
-}


{- UNUSED
          -- If we encounter a dotted constructor, we simply
          -- compute the pattern variable context
          -- and then treat the pattern as dot pattern.
          p@(ConP pi n ps) | dottedPat pi -> do
            (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <-
              checkConstructorPattern (coPat pi) n ps
            local (const cxt') $
              checkPattern' flex ins domEr $ DotP $ patternToExpr p
-}

          DotP Expr
e -> do
            -- create an informative, but irrelevant identifier for dot pattern
            let xp :: Name
xp = String -> Name
fresh (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ case Expr
e of Var Name
z -> Name -> String
suggestion Name
z; Expr
_ -> String -> String
Util.parens (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Expr -> String
forall a. Show a => a -> String
show Expr
e
            Name
-> Domain
-> (Int
    -> TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
Name
-> Domain
-> (Int
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (Int -> TVal -> m a) -> m a
newWithGen Name
xp Domain
domEr ((Int
  -> TVal
  -> TypeCheck
       ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
 -> TypeCheck
      ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> (Int
    -> TVal
    -> TypeCheck
         ([Goal], Substitution, TCContext, Pattern, TVal, Bool))
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a b. (a -> b) -> a -> b
$ \ Int
k TVal
xv -> do
                       TCContext
cxt' <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
                       -- traceCheck ("Returning type " ++ show vb) $
                       ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
-> TypeCheck ([Goal], Substitution, TCContext, Pattern, TVal, Bool)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Expr -> Domain -> Goal
DotFlex Int
k (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e) Domain
domEr Goal -> [Goal] -> [Goal]
forall a. a -> [a] -> [a]
: [Goal]
flex
                              ,Substitution
ins
                              ,TCContext
cxt'
                              ,Pattern -> Pattern
forall e. Pat e -> Pat e
maybeErase (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Expr -> Pattern
forall e. e -> Pat e
DotP Expr
e -- $ Var xp -- DotP $ Meta k -- e -- Meta k
                              -- ,maybeErase $ -- AbsurdP -- VarP $ show e
                              ,TVal
xv
                              ,Bool
False) -- TODO: Erase in e/ Meta subst!
{- original code
                    do let (k, delta') = cxtPush dec av delta
                       vb <- whnf (update env x (VGen k)) b
                       return ((k,(e,Domain av dec)):flex
                              ,ins
                              ,rho
                              ,delta'
                              ,vb)
-}

    where
      maybeErase :: Pat e -> Pat e
maybeErase Pat e
p = if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
decEr then Pat e -> Pat e
forall e. Pat e -> Pat e
ErasedP Pat e
p else Pat e
p

      checkConstructorPattern :: ConK
-> QName
-> [Pattern]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (TVal,
      ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool))
checkConstructorPattern ConK
co QName
n [Pattern]
pl = do
                 Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TVal -> Bool
isFunType TVal
av) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"higher-order matching of pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not allowed")
-- TODO: ensure that matchings against erased arguments are forced
--                 when (erased dec) $ throwErrorMsg $ "checkPattern: cannot match on erased argument " ++ show p ++ " : " ++ show av

                 ConSig {Maybe ([Name], [Pattern])
conPars :: Maybe ([Name], [Pattern])
conPars :: SigDef -> Maybe ([Name], [Pattern])
conPars, lhsTyp :: SigDef -> Maybe (Name, TVal)
lhsTyp = Maybe (Name, TVal)
sz, [Bool]
recOccs :: [Bool]
recOccs :: SigDef -> [Bool]
recOccs, symbTyp :: SigDef -> TVal
symbTyp = TVal
vc, Name
dataName :: Name
dataName :: SigDef -> Name
dataName, Int
dataPars :: Int
dataPars :: SigDef -> Int
dataPars} <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n

                 -- the following is a hack to still support old-style
                 --   add .($ i) (zero i) ...
                 -- fun defs:  if (zero i) is matched against (Nat flexvar$i)
                 -- we use the old constructor type [i : Size] -> Nat $i
                 -- else, the new one [j < i] -> Nat i
                 let flexK :: Int -> Goal -> Bool
flexK Int
k (DotFlex Int
k' Maybe Expr
_ Domain
_) = Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'
                     flexK Int
k Goal
_ = Bool
False
                     -- use lhs con type only if sizeindex is not a rigid var
                     isFlex :: TVal -> Bool
isFlex (VGen Int
k) = (Goal -> Bool) -> [Goal] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any (Int -> Goal -> Bool
flexK Int
k) [Goal]
flex
                     isFlex TVal
_ = Bool
True
                     isSz :: Maybe (Name, TVal)
isSz = if ConK
co ConK -> ConK -> Bool
forall a. Eq a => a -> a -> Bool
== ConK
Cons then Maybe (Name, TVal)
sz else Maybe (Name, TVal)
forall a. Maybe a
Nothing
                 TVal
vc <- QName
-> Maybe ([Name], [Pattern])
-> TVal
-> Maybe (Name, TVal)
-> (TVal -> Bool)
-> Int
-> TVal
-> TypeCheck TVal
instConLType QName
n Maybe ([Name], [Pattern])
conPars TVal
vc Maybe (Name, TVal)
isSz TVal -> Bool
isFlex Int
dataPars (TVal -> TypeCheck TVal) -> TypeCheck TVal -> TypeCheck TVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVal -> TypeCheck TVal
force TVal
av
{-
                 vc <- case sz of
                         Nothing -> instConType n nPars vc =<< force av
                         Just vc -> instConType n (nPars+1) vc =<< force av
-}

                 -- (flex',ins',cxt',vc',ple,pvs,absp) <-
                 (TVal
vc,) (([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
 -> (TVal,
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)))
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (TVal,
      ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dec
-> [Goal]
-> Substitution
-> TVal
-> [Pattern]
-> TypeCheck
     ([Goal], Substitution, TCContext, TVal, [Pattern], [TVal], Bool)
checkPatterns Dec
decEr [Goal]
flex Substitution
ins TVal
vc [Pattern]
pl


      -- These checks are only relevant if a constructor is an actual match.
      nonDottedConstructorChecks :: QName
-> ConK
-> [Pattern]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
nonDottedConstructorChecks QName
n ConK
co [Pattern]
pl = do
        ConSig {Maybe ([Name], [Pattern])
conPars :: SigDef -> Maybe ([Name], [Pattern])
conPars :: Maybe ([Name], [Pattern])
conPars, lhsTyp :: SigDef -> Maybe (Name, TVal)
lhsTyp = Maybe (Name, TVal)
sz, [Bool]
recOccs :: SigDef -> [Bool]
recOccs :: [Bool]
recOccs, symbTyp :: SigDef -> TVal
symbTyp = TVal
vc, Name
dataName :: SigDef -> Name
dataName :: Name
dataName, Int
dataPars :: SigDef -> Int
dataPars :: Int
dataPars} <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n

        -- check that size argument of coconstr is dotted
        Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConK
co ConK -> ConK -> Bool
forall a. Eq a => a -> a -> Bool
== ConK
CoCons Bool -> Bool -> Bool
&& Maybe (Name, TVal) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Name, TVal)
sz) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
          let sizep :: Pattern
sizep = [Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
head [Pattern]
pl  -- 2012-01-22: WAS (pl !! nPars)
          Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Pattern -> Bool
isDotPattern Pattern
sizep) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
            String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"in pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", coinductive size sub pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
sizep String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be dotted"

        Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Dec
decEr Dec -> [Dec] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Pol -> Dec) -> [Pol] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map Pol -> Dec
forall pos. pos -> Decoration pos
Dec [Pol
Const,Pol
Rec]) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
          String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"cannot match pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" against non-computational argument"
        -- check not to match non-trivially against erased stuff
        Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dec
decEr Dec -> Dec -> Bool
forall a. Eq a => a -> a -> Bool
== Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
Const) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
          let failNotForced :: m ()
failNotForced = String -> m ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"checkPattern: constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of non-computational argument " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not forced"
          Maybe [(ConstructorInfo, Env)]
mcenvs <- TVal -> TypeCheck (Maybe [(ConstructorInfo, Env)])
matchingConstructors TVal
av
          case Maybe [(ConstructorInfo, Env)]
mcenvs of
             Maybe [(ConstructorInfo, Env)]
Nothing -> do -- now check whether dataName is a record type
               DataSig { [ConstructorInfo]
constructors :: SigDef -> [ConstructorInfo]
constructors :: [ConstructorInfo]
constructors } <- Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => Name -> m SigDef
lookupSymb Name
dataName
               Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
constructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall {m :: * -> *}. MonadAssert m => m ()
failNotForced
               () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             Just [] -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"checkPattern: no constructor matches type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av
             Just [(ConstructorInfo
ci, Env
_)] | ConstructorInfo -> QName
cName ConstructorInfo
ci QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
n -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             Maybe [(ConstructorInfo, Env)]
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall {m :: * -> *}. MonadAssert m => m ()
failNotForced




{- New treatment of size matching  (see examples/Sized/Cody.ma)

sized data O : Size -> Set
{ Z : [i : Size] -> O ($ i)
; S : [i : Size] -> O i -> O ($ i)
; L : [i : Size] -> (Nat -> O i) -> O ($ i)
; M : [i : Size] -> O i -> O i -> O ($ i)
}

fun deep : [i : Size] -> O i -> Nat -> Nat
{ deep i4 (M i3 (L j2 f) (S i2 (S i1 (S i x)))) n
  = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n)))
; deep i x n = n
}

Explicit form:  Size variables and their constraints are noted explicitely,
to be able to do untyped call extraction in the termination module.

 deep i4
  (M (i4 > i3)
       (L (i3 > j2) f)
       (S (i3 > i2)
            (S (i2 > i1)
                 (S (i1 > i) x)))) n
  = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n)))

i4, i3, ... are all rigid variables with constraints between them.
There is a tree hierarchy, but I do not know whether I can exploit
this.

  i4 > i3 > i2 > i1 > i
          > j3

This could be stored in a union-find-like data structure, or just in
the constraint matrix.

How to pattern match?

  id : [i : Size] -> List i -> List i
  id i (cons (i > j) x xs) = cons j x (id j xs)

Only a size variable matches a size arguments

  match  (cons (i > j) x xs)   against   List i
  get    cons : [j : Size] -> Nat -> List j -> List ($ j)
  yield  x : Nat, xs : List j, cons j x xs : List ($ j)
  check  List ($ j) <= List i
 -}

-- checkDot does not need to extract
-- 2012-01-25 now we do since "extraction" turns also con.terms into records
checkGoal :: Substitution -> Goal -> TypeCheck ()
checkGoal :: Substitution
-> Goal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkGoal Substitution
subst (DotFlex Int
i Maybe Expr
me Domain
it) = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"dot pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Expr -> String
forall a. Show a => a -> String
show Maybe Expr
me) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
  case Int -> Substitution -> Maybe TVal
lookupSub Int
i Substitution
subst of
    Maybe TVal
Nothing -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"not instantiated"
    Just TVal
v -> Maybe Expr
-> (Expr
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Expr
me ((Expr
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Expr
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Expr
e -> do
      TVal
tv <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst (Domain -> TVal
forall a. Dom a -> a
typ Domain
it)
      StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
-> (TCContext
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ TCContext
ce -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"checking dot pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TCContext -> String
forall a. Show a => a -> String
show TCContext
ce String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show (Domain -> Dec
forall a. Dom a -> Dec
decor Domain
it) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv)
--      applyDec (decor it) $ do
      StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
resurrect (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do -- consider a DotP e always as irrelevant!
        Expr
e <- Kinded Expr -> Expr
forall a. Kinded a -> a
valueOf (Kinded Expr -> Expr)
-> TypeCheck (Kinded Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e TVal
tv
        TVal
v' <-  Expr -> TypeCheck TVal
whnf' Expr
e -- TODO: has subst erased terms?
        StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"inferred value" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"does not match given dot pattern value" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v') (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
          Pol
-> TVal
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal Pol
Pos TVal
tv TVal
v TVal
v' -- WAS: eqVal
checkGoal Substitution
subst (MaxMatches Int
n TVal
av) = do
  String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"checkGoal _ $ MaxMatches " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av)
  TVal
av' <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
av
  String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"checkGoal _ $ MaxMatches " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av')
  -- av' <- reval av'
  -- traceCheckM ("checkGoal: reevalutated " ++ show av')
  Maybe [(ConstructorInfo, Env)]
mcenvs <- TVal -> TypeCheck (Maybe [(ConstructorInfo, Env)])
matchingConstructors TVal
av'
  String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"checkGoal matching constructors = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe [(ConstructorInfo, Env)] -> String
forall a. Show a => a -> String
show Maybe [(ConstructorInfo, Env)]
mcenvs)
  StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> ([(ConstructorInfo, Env)]
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> Maybe [(ConstructorInfo, Env)]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"not a data type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av')
   (\ [(ConstructorInfo, Env)]
cenvs ->
      if [(ConstructorInfo, Env)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ConstructorInfo, Env)]
cenvs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n then String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
        if Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then String
"absurd pattern does not match since type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not empty"
         else
           String
"more than one constructor matches type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
av'
       else () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
   Maybe [(ConstructorInfo, Env)]
mcenvs
checkGoal Substitution
subst (DottedCons Dotted
dot Pattern
p TVal
av)
  | Dotted -> Bool
isDotted Dotted
dot =
      StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"confirming dotted constructor" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Pattern
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Pattern
p) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
        Substitution
-> Goal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkGoal Substitution
subst (Int -> TVal -> Goal
MaxMatches Int
1 TVal
av)
  | Bool
otherwise    = () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkRHS :: Substitution -> Expr -> TVal -> TypeCheck (Kinded Extr)
checkRHS :: Substitution -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkRHS Substitution
ins Expr
rhs TVal
v = do
   String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceCheckM (String
"checking rhs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
rhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v)
   String -> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter String
"right hand side" (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$ do
     -- first update measure according to substitution for dot variables
     TCContext
cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
     let rho :: Env2
rho = TCContext -> Env2
environ TCContext
cxt
     Maybe (Measure TVal)
mmu' <- (Measure TVal
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure TVal))
-> Maybe (Measure TVal)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Measure TVal))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
Traversable.mapM (Substitution
-> Measure TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure TVal)
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
ins) (Env2 -> Maybe (Measure TVal)
forall a. Environ a -> Maybe (Measure TVal)
envBound Env2
rho)
     (TCContext -> TCContext)
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ TCContext
_ -> TCContext
cxt { environ = rho { envBound = mmu' }}) (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$
       TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => m a -> m a
activateFuns (TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr))
-> TypeCheck (Kinded Expr) -> TypeCheck (Kinded Expr)
forall a b. (a -> b) -> a -> b
$
         Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
rhs TVal
v



-- TODO type directed unification

-- unifyIndices flex tv1 tv2
-- tv1 = D pars  inds  is the type of the pattern
-- tv2 = D pars' inds' is the type matched against
-- Note that in this case we can unify without using the principle of
-- injective data type constructors,
-- we are only calling unifyIndices from the constructor pattern case
-- in Checkpattern
unifyIndices :: [Int] -> Val -> Val -> TypeCheck Substitution
unifyIndices :: [Int]
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
unifyIndices [Int]
flex TVal
v1 TVal
v2 = StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
-> (TCContext
    -> StateT
         TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ TCContext
cxt -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"unifyIndices " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SemCxt -> String
forall a. Show a => a -> String
show (TCContext -> SemCxt
context TCContext
cxt) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |-") StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v1 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"?<=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
Pos) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v2) (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b. (a -> b) -> a -> b
$ do
-- {-
  case (TVal
v1,TVal
v2) of
    (VSing TVal
_ TVal
v1, VApp (VDef (DefId IdKind
DatK QName
d2)) [TVal]
vl2) ->
      (TVal
 -> TVal
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Int]
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
unifyIndices [Int]
flex) TVal
v2 (TVal
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> TypeCheck TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVal -> TypeCheck TVal
whnfClos TVal
v1
    (VApp (VDef (DefId IdKind
DatK QName
d1)) [TVal]
vl1, VApp (VDef (DefId IdKind
DatK QName
d2)) [TVal]
vl2) | QName
d1 QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
d2 -> do
      (DataSig { numPars :: SigDef -> Int
numPars = Int
np, symbTyp :: SigDef -> TVal
symbTyp = TVal
tv, positivity :: SigDef -> [Pol]
positivity = [Pol]
posl}) <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
d1
      [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList [Pol]
posl [Int]
flex TVal
tv [TVal]
vl1 [TVal]
vl2 -- unify also parameters to solve dot patterns
    (TVal, TVal)
_ ->
-- -}
         Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
Pos [Int]
flex TVal
vTopSort TVal
v1 TVal
v2
-- throwErrorMsg ("unifyIndices " ++ show v1 ++ " =?= " ++ show v2 ++ " failed, not applied to data types")

-- unify, but first produce whnf
instWh :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution
instWh :: Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instWh Pol
pos [Int]
flex TVal
tv TVal
w1 TVal
w2 = do
  TVal
v1 <- TVal -> TypeCheck TVal
whnfClos TVal
w1
  TVal
v2 <- TVal -> TypeCheck TVal
whnfClos TVal
w2
  Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
pos [Int]
flex TVal
tv TVal
v1 TVal
v2

-- | Check occurrence and return singleton substitution.
assignFlex :: Int -> Val -> TypeCheck Substitution
assignFlex :: Int
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
assignFlex Int
k TVal
v = do
  StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ([Int]
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int
k] TVal
v) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
    StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
      String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"variable " StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
k) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+>
      String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
" may not occur in " StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v
  Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Substitution
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b. (a -> b) -> a -> b
$ Int -> TVal -> Substitution
sgSub Int
k TVal
v

-- match v1 against v2 by unification , yielding a substition
inst :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution
inst :: Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
pos [Int]
flex TVal
tv TVal
v1 TVal
v2 = StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
-> (TCContext
    -> StateT
         TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ TCContext
cxt -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"inst " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SemCxt -> String
forall a. Show a => a -> String
show (TCContext -> SemCxt
context TCContext
cxt) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |-") StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v1 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"?<=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
pos) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v2 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall (m :: * -> *). Monad m => m Doc
colon StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv) (StateT
   TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b. (a -> b) -> a -> b
$ do
--  case tv of
--    (VPi dec x av env b) ->
  case (TVal
v1,TVal
v2) of
    (VGen Int
k, VGen Int
j) | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j -> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Substitution
emptySub
    (VGen Int
k, TVal
_) | Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
k [Int]
flex -> Int
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
assignFlex Int
k TVal
v2
    (TVal
_, VGen Int
k) | Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
k [Int]
flex -> Int
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
assignFlex Int
k TVal
v1

    -- injectivity of data type constructors is unsound in general
    (VApp (VDef (DefId IdKind
DatK QName
d1)) [TVal]
vl1,
     VApp (VDef (DefId IdKind
DatK QName
d2)) [TVal]
vl2) | QName
d1 QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
d2 ->  do
         (DataSig { Int
numPars :: SigDef -> Int
numPars :: Int
numPars, symbTyp :: SigDef -> TVal
symbTyp = TVal
tv, positivity :: SigDef -> [Pol]
positivity = [Pol]
posl }) <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
d1
         Int
-> [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList' Int
numPars [Pol]
posl [Int]
flex TVal
tv [TVal]
vl1 [TVal]
vl2
           -- ignore parameters (first numPars args)
           -- this is sound because we have irrelevance for parameters
           -- we assume injectivity for indices

    -- Constructor applications are represented as VRecord
    (VRecord (NamedRec ConK
_ QName
c1 Bool
_ Dotted
dot1) [(Name, TVal)]
rs1,
     VRecord (NamedRec ConK
_ QName
c2 Bool
_ Dotted
dot2) [(Name, TVal)]
rs2) | QName
c1 QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
c2 -> do
         Dotted
-> Dotted
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadIO m => Dotted -> Dotted -> m ()
alignDotted Dotted
dot1 Dotted
dot2
         SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
c1
         [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList [] [Int]
flex (SigDef -> TVal
symbTyp SigDef
sige) (((Name, TVal) -> TVal) -> [(Name, TVal)] -> [TVal]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TVal) -> TVal
forall a b. (a, b) -> b
snd [(Name, TVal)]
rs1) (((Name, TVal) -> TVal) -> [(Name, TVal)] -> [TVal]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TVal) -> TVal
forall a b. (a, b) -> b
snd [(Name, TVal)]
rs2)

    (VSucc TVal
v1',     VSucc TVal
v2')     -> Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instWh Pol
pos [Int]
flex TVal
tv TVal
v1' TVal
v2'
    (VSucc TVal
v,       TVal
VInfty)        -> Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instWh Pol
pos [Int]
flex TVal
tv TVal
v   TVal
VInfty
    (VSing TVal
v1' TVal
tv1, VSing TVal
v2' TVal
tv2) -> do
      Substitution
subst <- Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
pos [Int]
flex TVal
tv TVal
tv1 TVal
tv2
      TVal
u1 <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
v1'
      TVal
u2 <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
v2'
      TVal
tv1' <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
tv1
      Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
pos [Int]
flex TVal
tv1' TVal
u1 TVal
u2 StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> (Substitution
    -> StateT
         TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Substitution
-> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
compSubst Substitution
subst

-- HACK AHEAD
    (VUp TVal
v1 TVal
_, TVal
_) -> Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
pos [Int]
flex TVal
tv TVal
v1 TVal
v2
    (TVal
_, VUp TVal
v2 TVal
_) -> Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
pos [Int]
flex TVal
tv TVal
v1 TVal
v2
--    (VUp v1' a1, VUp v2' a2) -> instList flex [a1,v1'] [a2,v2']
--     (VPi dec x1 av1 env1 b1, VPi dec x2 av2 env2 b2) ->

{- TODO: REPAIR THIS
    _ -> traceCheck ("inst: WARNING! assuming " ++ show (context cxt) ++ " |- " ++ show v1 ++ " == " ++ show v2) $
           return [] -- throwErrorMsg $ "inst: NYI"
 -}
    (TVal, TVal)
_ -> do Pol
-> TVal
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal Pol
pos TVal
tv TVal
v1 TVal
v2 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> String -> m a
`throwTrace` (String
"inst: leqVal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ?<=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
pos String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
v2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed")
            Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Substitution
emptySub

instList :: [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution
instList :: [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList = Int
-> [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList' Int
0

-- unify lists, ignoring the first np items
instList' :: Int -> [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution
instList' :: Int
-> [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList' Int
np [Pol]
posl [Int]
flex TVal
tv [] [] = Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Substitution
emptySub
instList' Int
np [Pol]
posl [Int]
flex TVal
tv (TVal
v1:[TVal]
vl1) (TVal
v2:[TVal]
vl2) = do
  TVal
v1 <- TVal -> TypeCheck TVal
whnfClos TVal
v1
  TVal
v2 <- TVal -> TypeCheck TVal
whnfClos TVal
v2
  if (Int
np Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| [Int] -> TVal -> Bool
isMeta [Int]
flex TVal
v1 Bool -> Bool -> Bool
|| [Int] -> TVal -> Bool
isMeta [Int]
flex TVal
v2) then
    case TVal
tv of
      (VQuant PiSigma
Pi Name
x Domain
dom TVal
fv) -> do
        let pol :: Pol
pol = Domain -> Pol
forall a. LensPol a => a -> Pol
getPol Domain
dom  -- WAS: (headPosl posl)
        Substitution
subst <- Pol
-> [Int]
-> TVal
-> TVal
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
inst Pol
pol [Int]
flex (Domain -> TVal
forall a. Dom a -> a
typ Domain
dom) TVal
v1 TVal
v2
        [TVal]
vl1' <- (TVal -> TypeCheck TVal)
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst) [TVal]
vl1
        [TVal]
vl2' <- (TVal -> TypeCheck TVal)
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst) [TVal]
vl2
        TVal
v    <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
v1
        TVal
fv   <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
fv
        TVal
vb   <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
v
        Substitution
subst' <- Int
-> [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList' (Int
np Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Pol] -> [Pol]
tailPosl [Pol]
posl) [Int]
flex TVal
vb [TVal]
vl1' [TVal]
vl2'
        Substitution
-> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
compSubst Substitution
subst Substitution
subst'
   else
    case TVal
tv of
      (VQuant PiSigma
Pi Name
x Domain
dom TVal
fv) -> do
        TVal
vb   <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
v2
        Int
-> [Pol]
-> [Int]
-> TVal
-> [TVal]
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
instList' (Int
np Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Pol] -> [Pol]
tailPosl [Pol]
posl) [Int]
flex TVal
vb [TVal]
vl1 [TVal]
vl2
instList' Int
np [Pol]
pos [Int]
flex TVal
tv [TVal]
vl1 [TVal]
vl2 = String
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT
      TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution)
-> String
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall a b. (a -> b) -> a -> b
$ String
"internal error: instList' " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, [Pol], [Int], TVal, [TVal], [TVal]) -> String
forall a. Show a => a -> String
show (Int
np,[Pol]
pos,[Int]
flex,TVal
tv,[TVal]
vl1,[TVal]
vl2) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not handled"

headPosl :: [Pol] -> Pol
headPosl :: [Pol] -> Pol
headPosl [] = Pol
mixed
headPosl (Pol
pos:[Pol]
_) = Pol
pos

tailPosl :: [Pol] -> [Pol]
tailPosl :: [Pol] -> [Pol]
tailPosl [] = []
tailPosl (Pol
_:[Pol]
posl) = [Pol]
posl


isMeta :: [Int] -> Val -> Bool
isMeta :: [Int] -> TVal -> Bool
isMeta [Int]
flex (VGen Int
k) = Int
k Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
flex
isMeta [Int]
_ TVal
_ = Bool
False

----------------------------------------------------------------------
-- * Substitution into values
----------------------------------------------------------------------

-- | Overloaded substitution of values for generic values (free variables).
class Substitute a where
  substitute :: Substitution -> a -> TypeCheck a

instance Substitute v => Substitute (x,v) where
  substitute :: Substitution -> (x, v) -> TypeCheck (x, v)
substitute Substitution
subst (x
x,v
v) = (x
x,) (v -> (x, v))
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
-> TypeCheck (x, v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst v
v

instance Substitute v => Substitute [v] where
  substitute :: Substitution -> [v] -> TypeCheck [v]
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> [v] -> TypeCheck [v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> [v] -> TypeCheck [v])
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> [v]
-> TypeCheck [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

instance Substitute v => Substitute (Maybe v) where
  substitute :: Substitution -> Maybe v -> TypeCheck (Maybe v)
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Maybe v -> TypeCheck (Maybe v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
Traversable.mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> Maybe v -> TypeCheck (Maybe v))
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> Maybe v
-> TypeCheck (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

instance Substitute v => Substitute (Map k v) where
  substitute :: Substitution -> Map k v -> TypeCheck (Map k v)
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Map k v -> TypeCheck (Map k v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map k a -> m (Map k b)
Traversable.mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> Map k v -> TypeCheck (Map k v))
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> Map k v
-> TypeCheck (Map k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

instance Substitute v => Substitute (OneOrTwo v) where
  substitute :: Substitution -> OneOrTwo v -> TypeCheck (OneOrTwo v)
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> OneOrTwo v -> TypeCheck (OneOrTwo v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> OneOrTwo a -> m (OneOrTwo b)
Traversable.mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> OneOrTwo v -> TypeCheck (OneOrTwo v))
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> OneOrTwo v
-> TypeCheck (OneOrTwo v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

instance Substitute v => Substitute (Dom v) where
  substitute :: Substitution -> Dom v -> TypeCheck (Dom v)
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Dom v -> TypeCheck (Dom v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Dom a -> m (Dom b)
Traversable.mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> Dom v -> TypeCheck (Dom v))
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> Dom v
-> TypeCheck (Dom v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

instance Substitute v => Substitute (Measure v) where
  substitute :: Substitution -> Measure v -> TypeCheck (Measure v)
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Measure v -> TypeCheck (Measure v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Measure a -> m (Measure b)
Traversable.mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> Measure v -> TypeCheck (Measure v))
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> Measure v
-> TypeCheck (Measure v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

instance Substitute v => Substitute (Bound v) where
  substitute :: Substitution -> Bound v -> TypeCheck (Bound v)
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Bound v -> TypeCheck (Bound v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bound a -> m (Bound b)
Traversable.mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> Bound v -> TypeCheck (Bound v))
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> Bound v
-> TypeCheck (Bound v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

instance Substitute v => Substitute (Sort v) where
  substitute :: Substitution -> Sort v -> TypeCheck (Sort v)
substitute = (v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Sort v -> TypeCheck (Sort v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Sort a -> m (Sort b)
Traversable.mapM ((v
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
 -> Sort v -> TypeCheck (Sort v))
-> (Substitution
    -> v
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v)
-> Substitution
-> Sort v
-> TypeCheck (Sort v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution
-> v
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) v
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute

-- substitute generic variable in value
instance Substitute Val where
  substitute :: Substitution -> TVal -> TypeCheck TVal
substitute Substitution
subst TVal
v = do -- enterDoc (text "substitute" <$> prettyTCM v) $ do
    let sub :: a -> TypeCheck a
sub a
v = Substitution -> a -> TypeCheck a
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst a
v
    case TVal
v of
      VGen Int
k                -> TVal -> TypeCheck TVal
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ Int -> Substitution -> TVal
valuateGen Int
k Substitution
subst
      VApp TVal
v1 [TVal]
vl            -> (TVal -> TVal -> TypeCheck TVal)
-> TVal -> [TVal] -> TypeCheck TVal
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM TVal -> TVal -> TypeCheck TVal
app (TVal -> [TVal] -> TypeCheck TVal)
-> (TypeCheck TVal,
    StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal])
-> TypeCheck TVal
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
v1, [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
forall {a}. Substitute a => a -> TypeCheck a
sub [TVal]
vl)
      VSing TVal
v1 TVal
vt           -> TVal -> TVal -> TypeCheck TVal
vSing (TVal -> TVal -> TypeCheck TVal)
-> (TypeCheck TVal, TypeCheck TVal) -> TypeCheck TVal
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
v1, TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
vt) -- TODO: Check reevaluation necessary?

      VSucc TVal
v1              -> TVal -> TVal
succSize  (TVal -> TVal) -> TypeCheck TVal -> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
v1
      VMax  [TVal]
vs              -> [TVal] -> TVal
maxSize   ([TVal] -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
-> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVal -> TypeCheck TVal)
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst) [TVal]
vs
      VPlus [TVal]
vs              -> [TVal] -> TVal
plusSizes ([TVal] -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
-> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVal -> TypeCheck TVal)
-> [TVal]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [TVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst) [TVal]
vs

      VCase TVal
v1 TVal
tv1 Env
env [Clause]
cl   -> TVal -> TVal -> Env -> [Clause] -> TVal
VCase (TVal -> TVal -> Env -> [Clause] -> TVal)
-> TypeCheck TVal
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (TVal -> Env -> [Clause] -> TVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
v1 StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  (TVal -> Env -> [Clause] -> TVal)
-> TypeCheck TVal
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Env -> [Clause] -> TVal)
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
tv1 StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  (Env -> [Clause] -> TVal)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     ([Clause] -> TVal)
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall {a}. Substitute a => a -> TypeCheck a
sub Env
env StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  ([Clause] -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
-> TypeCheck TVal
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Clause]
cl
      VMeasured Measure TVal
mu TVal
bv       -> Measure TVal -> TVal -> TVal
VMeasured (Measure TVal -> TVal -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Measure TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure TVal)
forall {a}. Substitute a => a -> TypeCheck a
sub Measure TVal
mu StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
-> TypeCheck TVal -> TypeCheck TVal
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
bv
      VGuard Bound TVal
beta TVal
bv        -> Bound TVal -> TVal -> TVal
VGuard (Bound TVal -> TVal -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bound TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound TVal)
forall {a}. Substitute a => a -> TypeCheck a
sub Bound TVal
beta StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
-> TypeCheck TVal -> TypeCheck TVal
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
bv

      VBelow LtLe
ltle TVal
v         -> LtLe -> TVal -> TVal
VBelow LtLe
ltle (TVal -> TVal) -> TypeCheck TVal -> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
v

      VQuant PiSigma
pisig Name
x Domain
dom TVal
fv -> PiSigma -> Name -> Domain -> TVal -> TVal
VQuant PiSigma
pisig Name
x (Domain -> TVal -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Domain
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Domain
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Domain
forall {a}. Substitute a => a -> TypeCheck a
sub Domain
dom StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
-> TypeCheck TVal -> TypeCheck TVal
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
fv
      VRecord RecInfo
ri [(Name, TVal)]
rs         -> RecInfo -> [(Name, TVal)] -> TVal
VRecord RecInfo
ri ([(Name, TVal)] -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, TVal)]
-> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, TVal)]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, TVal)]
forall {a}. Substitute a => a -> TypeCheck a
sub [(Name, TVal)]
rs
      VPair TVal
v1 TVal
v2           -> TVal -> TVal -> TVal
VPair (TVal -> TVal -> TVal)
-> TypeCheck TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
v1 StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) (TVal -> TVal)
-> TypeCheck TVal -> TypeCheck TVal
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
v2
      VProj{}               -> TVal -> TypeCheck TVal
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TVal
v

      VLam Name
x Env
env Expr
b          -> (Env -> Expr -> TVal) -> Expr -> Env -> TVal
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> Env -> Expr -> TVal
VLam Name
x) Expr
b (Env -> TVal)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
-> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall {a}. Substitute a => a -> TypeCheck a
sub Env
env
      VConst TVal
v              -> TVal -> TVal
VConst (TVal -> TVal) -> TypeCheck TVal -> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
v
      VAbs Name
x Int
i TVal
v Substitution
valu       -> Name -> Int -> TVal -> Substitution -> TVal
VAbs Name
x Int
i TVal
v (Substitution -> TVal)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
-> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall {a}. Substitute a => a -> TypeCheck a
sub Substitution
valu
      VClos Env
env Expr
e           -> (Env -> Expr -> TVal) -> Expr -> Env -> TVal
forall a b c. (a -> b -> c) -> b -> a -> c
flip Env -> Expr -> TVal
VClos Expr
e (Env -> TVal)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
-> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall {a}. Substitute a => a -> TypeCheck a
sub Env
env
      VUp TVal
v1 TVal
vt             -> Bool -> TVal -> TVal -> TypeCheck TVal
up Bool
False (TVal -> TVal -> TypeCheck TVal)
-> (TypeCheck TVal, TypeCheck TVal) -> TypeCheck TVal
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
v1, TVal -> TypeCheck TVal
forall {a}. Substitute a => a -> TypeCheck a
sub TVal
vt)
      VSort Sort TVal
s               -> Sort TVal -> TVal
VSort (Sort TVal -> TVal) -> TypeCheck (Sort TVal) -> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort TVal -> TypeCheck (Sort TVal)
forall {a}. Substitute a => a -> TypeCheck a
sub Sort TVal
s
      TVal
VZero                 -> TVal -> TypeCheck TVal
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ TVal
v
      TVal
VInfty                -> TVal -> TypeCheck TVal
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ TVal
v
      TVal
VIrr                  -> TVal -> TypeCheck TVal
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ TVal
v
      VDef DefId
id               -> TVal -> TypeCheck TVal
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ DefId -> TVal
vDef DefId
id  -- because empty list of apps will be rem.
      VMeta Int
x Env
env Int
n         -> (Env -> Int -> TVal) -> Int -> Env -> TVal
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Env -> Int -> TVal
VMeta Int
x) Int
n (Env -> TVal)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
-> TypeCheck TVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall {a}. Substitute a => a -> TypeCheck a
sub Env
env
{- REDUNDANT
      _ -> error $ "substitute: internal error: not defined for " ++ show v
-}

instance Substitute SemCxt where
  substitute :: Substitution -> SemCxt -> TypeCheck SemCxt
substitute Substitution
subst SemCxt
delta = do
    Map Int (OneOrTwo Domain)
cxt' <- Substitution
-> Map Int (OneOrTwo Domain)
-> TypeCheck (Map Int (OneOrTwo Domain))
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst (SemCxt -> Map Int (OneOrTwo Domain)
cxt SemCxt
delta)
    SemCxt -> TypeCheck SemCxt
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SemCxt -> TypeCheck SemCxt) -> SemCxt -> TypeCheck SemCxt
forall a b. (a -> b) -> a -> b
$ SemCxt
delta { cxt = cxt' }

-- | Substitute in environment.
instance Substitute Env where
  substitute :: Substitution
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
substitute Substitution
subst (Environ [(Name, TVal)]
rho Maybe (Measure TVal)
mmeas) =
    [(Name, TVal)] -> Maybe (Measure TVal) -> Env
forall a. [(Name, a)] -> Maybe (Measure TVal) -> Environ a
Environ ([(Name, TVal)] -> Maybe (Measure TVal) -> Env)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, TVal)]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Measure TVal) -> Env)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Substitution
-> [(Name, TVal)]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, TVal)]
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst [(Name, TVal)]
rho StateT
  TCState
  (ReaderT TCContext (ExceptT TraceError IO))
  (Maybe (Measure TVal) -> Env)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Measure TVal))
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) (a -> b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Substitution
-> Maybe (Measure TVal)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Measure TVal))
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst Maybe (Measure TVal)
mmeas

instance Substitute Substitution where
  substitute :: Substitution
-> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
substitute Substitution
subst2 Substitution
subst1 = Substitution
-> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
compSubst Substitution
subst1 Substitution
subst2

-- | "merge" substitutions by first applying the second to the first, then
--   appending them @t[sigma][tau] = t[sigma . tau]@
compSubst :: Substitution -> Substitution -> TypeCheck Substitution
compSubst :: Substitution
-> Substitution
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
compSubst (Valuation [(Int, TVal)]
subst1) subst2 :: Substitution
subst2@(Valuation [(Int, TVal)]
subst2') =
    [(Int, TVal)] -> Substitution
Valuation ([(Int, TVal)] -> Substitution)
-> ([(Int, TVal)] -> [(Int, TVal)])
-> [(Int, TVal)]
-> Substitution
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Int, TVal)] -> [(Int, TVal)] -> [(Int, TVal)]
forall a. [a] -> [a] -> [a]
++ [(Int, TVal)]
subst2') ([(Int, TVal)] -> Substitution)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Int, TVal)]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Substitution
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Substitution
-> [(Int, TVal)]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Int, TVal)]
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst2 [(Int, TVal)]
subst1

----------------------------------------------------------------------
-- * Size checking
----------------------------------------------------------------------

{- TODO: From a sized data declaration

  sized data D pars : Size -> t
  { c : [j : Size] -> args -> D pars $j ts
  }

  with constructor type

   c : .pars -> [j : Size] -> args -> D pars $j ts

  extract new-style constructor type

   c :  .pars -> [i : Size] -> [j < i : Size] -> args -> D pars i ts

  Then replace in ConSig filed isSized :: Sized  by :: Maybe Expr
  which stores the new-style constructor type

-}

mkConLType :: Int -> Expr -> (Name, Expr)
mkConLType :: Int -> Expr -> (Name, Expr)
mkConLType Int
npars Expr
t =
  let (Telescope (TBind
sizetb : [TBind]
tel), Expr
t0) = Expr -> (Telescope, Expr)
typeToTele Expr
t
  in case Expr -> (Expr, [Expr])
spineView Expr
t0 of
    (d :: Expr
d@(Def (DefId IdKind
DatK QName
_)), [Expr]
args) ->
      let ([Expr]
pars, Expr
sizeindex : [Expr]
inds) = Int -> [Expr] -> ([Expr], [Expr])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
npars [Expr]
args
          i :: Name
i     = String -> Name
fresh String
"s!ze"
          args' :: [Expr]
args' = [Expr]
pars [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ Name -> Expr
Var Name
i Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [Expr]
inds
          core :: Expr
core  = (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr -> Expr -> Expr
App Expr
d [Expr]
args'
          tbi :: TBind
tbi   = Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
i (Dom Expr -> TBind) -> Dom Expr -> TBind
forall a b. (a -> b) -> a -> b
$ Dec -> Dom Expr
sizeDomain Dec
irrelevantDec
          tbj :: TBind
tbj   = TBind
sizetb { boundDom = belowDomain irrelevantDec Lt (Var i) }
          tel' :: Telescope
tel'  = [TBind] -> Telescope
Telescope ([TBind] -> Telescope) -> [TBind] -> Telescope
forall a b. (a -> b) -> a -> b
$ TBind
tbi TBind -> [TBind] -> [TBind]
forall a. a -> [a] -> [a]
: TBind
tbj TBind -> [TBind] -> [TBind]
forall a. a -> [a] -> [a]
: [TBind]
tel
      in (Name
i, Telescope -> Expr -> Expr
teleToType Telescope
tel' Expr
core)
    (Expr, [Expr])
_ -> String -> (Name, Expr)
forall a. HasCallStack => String -> a
error (String -> (Name, Expr)) -> String -> (Name, Expr)
forall a b. (a -> b) -> a -> b
$ String
"conLType " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
npars String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"): illformed constructor type"



-- * check wether the data type is sized type


-- check data declaration type
-- called from typeCheckDeclaration (DataDecl{})
-- parameters : number of params, type
szType :: Co -> Int -> TVal -> TypeCheck ()
szType :: Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szType Co
co Int
p TVal
tv = Int
-> TVal
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a
doVParams Int
p TVal
tv ((TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ TVal
tv' -> do
    let polsz :: Pol
polsz = if Co
coCo -> Co -> Bool
forall a. Eq a => a -> a -> Bool
==Co
Ind then Pol
Pos else Pol
Neg
    case TVal
tv' of
      VQuant PiSigma
Pi Name
x (Domain TVal
av Kind
ki Dec
dec) TVal
fv | TVal -> Bool
isVSize TVal
av Bool -> Bool -> Bool
&& Bool -> Bool
not (Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec) Bool -> Bool -> Bool
&& Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
polsz -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      TVal
_ -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"not a sized type, target " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must have non-erased domain " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Class -> String
forall a. Show a => a -> String
show Class
Size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with polarity " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
polsz

-- * constructors of sized type

-- check data constructors
-- called from typeCheckConstructor
szConstructor :: Name -> Co -> Int -> TVal -> TypeCheck ()
szConstructor :: Name
-> Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szConstructor Name
n Co
co Int
p TVal
tv = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"szConstructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :") StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
  Int
-> TVal
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a
doVParams Int
p TVal
tv ((TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ TVal
tv' ->
    case TVal
tv' of
       VQuant PiSigma
Pi Name
x Domain
dom TVal
fv | TVal -> Bool
isVSize (Domain -> TVal
forall a. Dom a -> a
typ Domain
dom) ->
          Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
k TVal
xv TVal
bv -> do
            Name
-> Co
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarUsage Name
n Co
co Int
p Int
k TVal
bv
       TVal
_ -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"not a valid sized constructor: expected size quantification"

szSizeVarUsage :: Name -> Co -> Int -> Int -> TVal -> TypeCheck ()
szSizeVarUsage :: Name
-> Co
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarUsage Name
n Co
co Int
p Int
i TVal
tv = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"szSizeVarUsage of" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
i) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"in" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
    case TVal
tv of
       VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> do
          let av :: TVal
av = Domain -> TVal
forall a. Dom a -> a
typ Domain
dom
          Name
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarDataArgs Name
n Int
p Int
i TVal
av  -- recursive calls of for D..i..
          StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"checking" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
av StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
" to be " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              (if Co
co Co -> Co -> Bool
forall a. Eq a => a -> a -> Bool
== Co
CoInd then String
"antitone" else String
"isotone") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in variable")
              StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
i)) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
            Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szMono Co
co Int
i TVal
av                -- monotone in i
          Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
xv TVal
bv -> do
            Name
-> Co
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarUsage Name
n Co
co Int
p Int
i TVal
bv

       TVal
_ -> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarTarget Int
p Int
i TVal
tv

-- check that Target is of form D ... (Succ i) ...
szSizeVarTarget :: Int -> Int -> TVal -> TypeCheck ()
szSizeVarTarget :: Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarTarget Int
p Int
i TVal
tv = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"szSizeVarTarget, variable" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
i) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (String
"argument no. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in") StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
    let err :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
err = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"expected target" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"of size" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (TVal -> TVal
VSucc (Int -> TVal
VGen Int
i))
    case TVal
tv of
       VSing TVal
_ TVal
tv -> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarTarget Int
p Int
i (TVal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TypeCheck TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVal -> TypeCheck TVal
whnfClos TVal
tv
       VApp TVal
d [TVal]
vl -> do
               TVal
v0 <- TVal -> TypeCheck TVal
whnfClos ([TVal]
vl [TVal] -> Int -> TVal
forall a. HasCallStack => [a] -> Int -> a
!! Int
p)
               case TVal
v0 of
                 (VSucc (VGen Int
i')) | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 TVal
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
err
       TVal
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
err


-- check that rec. arguments are of form D ... i ....
-- and size used nowhere else ?? -- Andreas, 2009-11-27 TOO STRICT!
{- accepts, for instance

   Nat -> Ord i      as argument of a constructor of  Ord ($ i)
   List (Rose A i)   as argument of a constructor of  Rose A ($i)
 -}
szSizeVarDataArgs :: Name -> Int -> Int -> TVal -> TypeCheck ()
szSizeVarDataArgs :: Name
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarDataArgs Name
n Int
p Int
i TVal
tv = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"sizeVarDataArgs" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
i) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"in" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
   case TVal
tv of

     {- case D pars sizeArg args -}
     VApp (VDef (DefId IdKind
DatK (QName Name
m))) [TVal]
vl | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> do
        let ([TVal]
pars, TVal
v0 : [TVal]
idxs) = Int -> [TVal] -> ([TVal], [TVal])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
p [TVal]
vl
        TVal
v0 <- TVal -> TypeCheck TVal
whnfClos TVal
v0
        case TVal
v0 of
          VGen Int
i' | Int
i' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i -> do
            [TVal]
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([TVal]
pars [TVal] -> [TVal] -> [TVal]
forall a. [a] -> [a] -> [a]
++ [TVal]
idxs) ((TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ TVal
v -> [Int]
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int
i] TVal
v StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> (Bool
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= do
              StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *).
MonadError TraceError m =>
m Doc -> Bool -> m ()
boolToErrorDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
 -> Bool
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
                String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"variable" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
i) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+>
                String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"may not occur in" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v
          TVal
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
                String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"wrong size index" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
v0 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+>
                String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"at recursive occurrence" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv

-- not necessary: check for monotonicity above
--     {- case D' pars sizeArg args -}
--     VApp (VDef m) vl | n /= m -> do

     VApp TVal
v1 [TVal]
vl -> (TVal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [TVal]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ TVal
v -> TVal -> TypeCheck TVal
whnfClos TVal
v TypeCheck TVal
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (a
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarDataArgs Name
n Int
p Int
i) (TVal
v1TVal -> [TVal] -> [TVal]
forall a. a -> [a] -> [a]
:[TVal]
vl)

     VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> do
       Name
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarDataArgs Name
n Int
p Int
i (Domain -> TVal
forall a. Dom a -> a
typ Domain
dom)
       Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
xv TVal
bv -> do
          Name
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarDataArgs Name
n Int
p Int
i TVal
bv

     TVal
fv | TVal -> Bool
isFun TVal
fv ->
       Name
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Name -> (TVal -> m a) -> m a
addName (TVal -> Name
absName TVal
fv) ((TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ TVal
xv -> Name
-> Int
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szSizeVarDataArgs Name
n Int
p Int
i (TVal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TypeCheck TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
xv
{-
     VLam x env b ->
       addName x $ \ xv -> do
         bv <- whnf (update env x xv) b
         szSizeVarDataArgs n p i bv
-}
     TVal
_ -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- REMOVED, 2009-11-28, replaced by monotonicity check
     VGen i' -> return $ i' /= i
     VSucc tv' -> szSizeVarDataArgs n p i tv'
 -}

-- doVParams number_of_params constructor_or_datatype_signature
-- skip over parameters of type signature of a constructor/data type
doVParams :: Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a
doVParams :: forall a. Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a
doVParams Int
0 TVal
tv TVal -> TypeCheck a
k = TVal -> TypeCheck a
k TVal
tv
doVParams Int
p (VQuant PiSigma
Pi Name
x Domain
dom TVal
fv) TVal -> TypeCheck a
k =
  Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int -> TVal -> TVal -> TypeCheck a) -> TypeCheck a)
-> (Int -> TVal -> TVal -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
xv TVal
bv -> do
    Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a
forall a. Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a
doVParams (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) TVal
bv TVal -> TypeCheck a
k

--------------------------------------
-- check for admissible  type

{-

 - admissibility needs to be check clausewise, because of Karl's example

   fun nonAdmissibleType : Unit -> Set

   fun diverge : (u : Unit) -> nonAdmissibleType u
   {
     diverge unit patterns = badRhs
   }

 - the type must be admissible in the current position
   only if the size pattern is a successor.
   If the pattern is a variable, then there is no induction on that size
   argument, so no limit case, so no upper semi-continuity necessary
   for the type.

 - when checking

     ... (s i) ps  admissible  (j : Size) -> A

   we will check

     A  admissible in j

   and continue with

     ... ps  admissible  A[s i / j]

   just to maintain type wellformedness.  The (s i) in A does not
   really matter, since there is no case distinction on ordinals.

 - a size pattern which is not inductive (meaning there is an
    inductive type indexed by that size) nor coinductive (meaning that
    the result type is coinductive and is indexed by that size) must
    be flagged unusable for termination checking.

 - the fun/cofun distinction could be inferred by the termination checker
   or be clausewise as in Agda 2

-}


admFunDef :: Co -> [Clause] -> TVal -> TypeCheck [Clause]
admFunDef :: Co
-> [Clause]
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
admFunDef Co
co [Clause]
cls TVal
tv = do
  ([Clause]
cls, [Co]
inco) <- [Clause] -> TVal -> TypeCheck ([Clause], [Co])
admClauses [Clause]
cls TVal
tv
  Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Co
coCo -> Co -> Bool
forall a. Eq a => a -> a -> Bool
==Co
CoInd Bool -> Bool -> Bool
&& Bool -> Bool
not (Co
co Co -> [Co] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Co]
inco)) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
    String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ TVal -> String
forall a. Show a => a -> String
show TVal
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a type of a cofun" -- ++ if co==Ind then "fun" else "cofun"
  [Clause]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Clause]
cls

admClauses :: [Clause] -> TVal -> TypeCheck ([Clause], [Co])
admClauses :: [Clause] -> TVal -> TypeCheck ([Clause], [Co])
admClauses [] TVal
tv = ([Clause], [Co]) -> TypeCheck ([Clause], [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
admClauses (Clause
cl:[Clause]
cls) TVal
tv = do
  (Clause
cl',[Co]
inco) <- Clause -> TVal -> TypeCheck (Clause, [Co])
admClause Clause
cl TVal
tv
  ([Clause]
cls',[Co]
inco') <- [Clause] -> TVal -> TypeCheck ([Clause], [Co])
admClauses [Clause]
cls TVal
tv
  ([Clause], [Co]) -> TypeCheck ([Clause], [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause
cl' Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: [Clause]
cls', [Co]
inco [Co] -> [Co] -> [Co]
forall a. [a] -> [a] -> [a]
++ [Co]
inco')

admClause :: Clause -> TVal -> TypeCheck (Clause, [Co])
admClause :: Clause -> TVal -> TypeCheck (Clause, [Co])
admClause (Clause TeleVal
tel [Pattern]
ps Maybe Expr
e) TVal
tv = String -> TypeCheck (Clause, [Co]) -> TypeCheck (Clause, [Co])
forall a. String -> a -> a
traceAdm (String
"admClause: admissibility of patterns " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Pattern] -> String
forall a. Show a => a -> String
show [Pattern]
ps) (TypeCheck (Clause, [Co]) -> TypeCheck (Clause, [Co]))
-> TypeCheck (Clause, [Co]) -> TypeCheck (Clause, [Co])
forall a b. (a -> b) -> a -> b
$
   [Pattern]
-> TVal
-> ([(Pattern, TVal)] -> TVal -> TypeCheck (Clause, [Co]))
-> TypeCheck (Clause, [Co])
forall a.
[Pattern]
-> TVal
-> ([(Pattern, TVal)] -> TVal -> TypeCheck a)
-> TypeCheck a
introPatterns [Pattern]
ps TVal
tv (([(Pattern, TVal)] -> TVal -> TypeCheck (Clause, [Co]))
 -> TypeCheck (Clause, [Co]))
-> ([(Pattern, TVal)] -> TVal -> TypeCheck (Clause, [Co]))
-> TypeCheck (Clause, [Co])
forall a b. (a -> b) -> a -> b
$ \ [(Pattern, TVal)]
pvs TVal
_ -> do
       ([Pattern]
ps', [Co]
inco) <- [(Pattern, TVal)] -> TVal -> TypeCheck ([Pattern], [Co])
admPatterns [(Pattern, TVal)]
pvs TVal
tv
       (Clause, [Co]) -> TypeCheck (Clause, [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
tel [Pattern]
ps' Maybe Expr
e, [Co]
inco)

admPatterns :: [(Pattern,Val)] -> TVal -> TypeCheck ([Pattern], [Co])
admPatterns :: [(Pattern, TVal)] -> TVal -> TypeCheck ([Pattern], [Co])
admPatterns [] TVal
tv = do
  Bool
isCo <- TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
endsInCo TVal
tv
  ([Pattern], [Co]) -> TypeCheck ([Pattern], [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], if Bool
isCo then [Co
CoInd] else [])
admPatterns ((Pattern
p,TVal
v):[(Pattern, TVal)]
pvs) TVal
tv = do
   (Pattern
p, [Co]
inco1)  <- Pattern -> TVal -> TypeCheck (Pattern, [Co])
admPattern Pattern
p TVal
tv
   TVal
bv <- TVal -> TVal -> TypeCheck TVal
piApp TVal
tv TVal
v
   ([Pattern]
ps, [Co]
inco2) <- [(Pattern, TVal)] -> TVal -> TypeCheck ([Pattern], [Co])
admPatterns [(Pattern, TVal)]
pvs TVal
bv
   ([Pattern], [Co]) -> TypeCheck ([Pattern], [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern
pPattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
:[Pattern]
ps, [Co]
inco1 [Co] -> [Co] -> [Co]
forall a. [a] -> [a] -> [a]
++ [Co]
inco2)

{-
-- turn a pattern into a value
-- extend delta by generic values but do not introduce their types
evalPat :: Pattern -> (Val -> TypeCheck a) -> TypeCheck a
evalPat p f =
    case p of
      VarP n -> addName n f
      ConP co n [] -> f (VCon co n)
      ConP co n pl -> evalPats pl $ \ vl -> f (VApp (VCon co n) vl)
      SuccP p -> evalPat p $ \ v -> f (VSucc v)
-- DOES NOT WORK SINCE e has unbound variables
      DotP e -> do
        v <- whnf' e
        f v

evalPats :: [Pattern] -> ([Val] -> TypeCheck a) -> TypeCheck a
evalPats [] f = f []
evalPats (p:ps) f = evalPat p $ \ v -> evalPats ps $ \ vs -> f (v:vs)
-}

{-
evalPat :: Pattern -> TypeCheck (State TCContext Val)
evalPat p =
    case p of
      VarP n -> return $ State $ \ ce ->
        let (k, delta) = cxtPushGen (context ce)
            rho = update n (VGen k) (environ ce)
        in  (VGen k, TCContext { context = delta, environ = rho })
      ConP co n [] -> return (VCon co n)
      ConP co n pl -> do
        vl <- mapM evalPat pl
        return (VApp (VCon co n) vl)
      SuccP p -> do
       v <- evalPat p
       return (VSucc v)
-- TODO: does not work!
--      DotP e -> return $ State $ \ ce ->
-}




{- 2013-03-31 On instantiation of quantifiers [i < #] - F i

If F is upper semi-continuous then

  [i < #] -> F i   is a sub"set" of   F #

so we can instantiate i to #.  (Hughes et al., POPL 96; Abel, LMCS 08)

1) Consider the special case

  F i = [j < i] -> G i

Because # is a limit, thus, j < i < #  iff j < #, we reason:

  F # = [j < #] -> G j

  [i < #] -> F i
      = [i < #] -> [j < i] -> G j  (since # is a limit)
      = [j < #] -> G j

2) Consider the special case

  F i = [j <= i] -> G j

We have

  F # = [j <= #] -> G j
      = G # /\ ([j < #] -> G j)

  [i < #] -> F i
      = [i < #] -> [j <= i] -> G j
      = [j < #] -> G j

So if G is upper semi-continuous, so is F.

-}


-- | Check whether a type is upper semi-continuous.
lowerSemiCont :: Int -> TVal -> TypeCheck Bool
lowerSemiCont :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
lowerSemiCont Int
i TVal
tv = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall e (m :: * -> *). MonadError e m => m () -> m Bool
errorToBool (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
i TVal
tv

docNotLowerSemi :: Int -> TVal -> TypeCheck Doc
docNotLowerSemi :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
docNotLowerSemi Int
i TVal
av = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"type " StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
av StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+>
  String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
" not lower semi continuous in " StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
i)

lowerSemiContinuous :: Int -> TVal -> TypeCheck ()
lowerSemiContinuous :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
i TVal
av = do
  TVal
av <- TVal -> TypeCheck TVal
force TVal
av
  let fallback :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback = Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szAntitone Int
i TVal
av StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> m Doc -> m a
`newErrorDoc` Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
docNotLowerSemi Int
i TVal
av

  case TVal
av of

    -- [j < i] & F j  is lower semi-cont in i
    -- because [i < #] & [j < i] & F j is the same as [j < #] & F j
    -- [but what if i in FV(F j)? should not matter!] 2013-04-01
    VQuant PiSigma
Sigma Name
x dom :: Domain
dom@Domain{ typ :: forall a. Dom a -> a
typ = VBelow LtLe
Lt (VGen Int
i') } TVal
fv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- [j <= i] & F j  is lower semi-cont in i if F is
    VQuant PiSigma
Sigma Name
x dom :: Domain
dom@Domain{ typ :: forall a. Dom a -> a
typ = VBelow LtLe
Le (VGen Int
i') } TVal
fv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' -> do
      Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
j TVal
xv TVal
bv -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
j TVal
bv

    -- Sigma-type general case
    VQuant PiSigma
Sigma Name
x dom :: Domain
dom@Domain{ typ :: forall a. Dom a -> a
typ = TVal
av } TVal
fv -> do
      Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
i TVal
av
      Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
xv TVal
bv -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
i TVal
bv

    VApp (VDef (DefId IdKind
DatK QName
n)) [TVal]
vl -> do
      SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
      case SigDef
sige of

        -- finite tuple type
        DataSig { symbTyp :: SigDef -> TVal
symbTyp = TVal
dv, constructors :: SigDef -> [ConstructorInfo]
constructors = [ConstructorInfo]
cis, isTuple :: SigDef -> Bool
isTuple = Bool
True } -> do
          -- match target of constructor against tv to instantiate
          --  c : ... -> D ps  -- ps = snd (cPatFam ci)
          Maybe (Env, ConstructorInfo)
mrhoci <- [StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Maybe (Env, ConstructorInfo))]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Env, ConstructorInfo))
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
Util.firstJustM ([StateT
    TCState
    (ReaderT TCContext (ExceptT TraceError IO))
    (Maybe (Env, ConstructorInfo))]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo)))
-> [StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo))]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Env, ConstructorInfo))
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo)))
-> [ConstructorInfo]
-> [StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo))]
forall a b. (a -> b) -> [a] -> [b]
map (\ ConstructorInfo
ci -> (Env -> (Env, ConstructorInfo))
-> Maybe Env -> Maybe (Env, ConstructorInfo)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,ConstructorInfo
ci) (Maybe Env -> Maybe (Env, ConstructorInfo))
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Env, ConstructorInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Env
-> [Pattern]
-> [TVal]
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
nonLinMatchList Bool
False Env
forall a. Environ a
emptyEnv ((PatternsType, [Pattern]) -> [Pattern]
forall a b. (a, b) -> b
snd ((PatternsType, [Pattern]) -> [Pattern])
-> (PatternsType, [Pattern]) -> [Pattern]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> (PatternsType, [Pattern])
cPatFam ConstructorInfo
ci) [TVal]
vl TVal
dv) [ConstructorInfo]
cis
          case Maybe (Env, ConstructorInfo)
mrhoci of
            Maybe (Env, ConstructorInfo)
Nothing -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback
            Just (Env
rho,ConstructorInfo
ci) -> if (ConstructorInfo -> Bool
cRec ConstructorInfo
ci) then StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback else do
              -- infinite tuples (recursive constructor) are not lower semi cont
              String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"lowerSemiContinuous: detected tuple type, checking components") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
                [FieldInfo]
-> Env
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
allComponentTypes (ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci) Env
rho (Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
i)

       -- i-sized inductive types are lower semi-cont in i
        DataSig { Int
numPars :: SigDef -> Int
numPars :: Int
numPars, isSized :: SigDef -> Sized
isSized = Sized
Sized, isCo :: SigDef -> Co
isCo = Co
Ind } | [TVal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TVal]
vl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
numPars -> do
          TVal
s <- TVal -> TypeCheck TVal
whnfClos (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ [TVal]
vl [TVal] -> Int -> TVal
forall a. HasCallStack => [a] -> Int -> a
!! Int
numPars -- the size argument is the first fgter the parameters
          case TVal
s of
            VGen Int
i' | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            TVal
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback

        -- finite inductive type
        DataSig { symbTyp :: SigDef -> TVal
symbTyp = TVal
dv, constructors :: SigDef -> [ConstructorInfo]
constructors = [ConstructorInfo]
cis, isCo :: SigDef -> Co
isCo = Co
Ind } ->
          -- if any cRec cis then fallback else do -- we loop on recursive data, so exclude
          -- check that we do not loop on the same data names...
          StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((QName
n QName -> [QName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([QName] -> Bool)
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [QName]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCContext -> [QName])
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) [QName]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> [QName]
callStack) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
          (TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
(TCContext -> TCContext)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ TCContext
ce -> TCContext
ce { callStack = n : callStack ce }) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
          -- match target of constructor against tv to instantiate
          --  c : ... -> D ps  -- ps = snd (cPatFam ci)
          [ConstructorInfo]
-> (ConstructorInfo
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ConstructorInfo]
cis ((ConstructorInfo
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (ConstructorInfo
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ ConstructorInfo
ci -> do
            Maybe Env
match <- Bool
-> Env
-> [Pattern]
-> [TVal]
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
nonLinMatchList Bool
False Env
forall a. Environ a
emptyEnv ((PatternsType, [Pattern]) -> [Pattern]
forall a b. (a, b) -> b
snd ((PatternsType, [Pattern]) -> [Pattern])
-> (PatternsType, [Pattern]) -> [Pattern]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> (PatternsType, [Pattern])
cPatFam ConstructorInfo
ci) [TVal]
vl TVal
dv
            Maybe Env
-> (Env
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Foldable.forM_ Maybe Env
match ((Env
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Env
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Env
rho -> do
                String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"lowerSemiContinuous: detected tuple type, checking components") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
                  [FieldInfo]
-> Env
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
allComponentTypes (ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci) Env
rho (Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
i)

        SigDef
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback
    TVal
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback

-- | Check whether a type is upper semi-continuous.
upperSemiCont :: Int -> TVal -> TypeCheck Bool
upperSemiCont :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
upperSemiCont Int
i TVal
tv = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall e (m :: * -> *). MonadError e m => m () -> m Bool
errorToBool (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
False Int
i TVal
tv
  -- 2013-03-30
  -- endsInSizedCo needs tv[0/i] = Top
  -- upperSemiCont does not need this, the target can also be constant in i

-- | @endsInSizedCo i tv@ checks that @tv@ is lower semi-continuous in @i@
--   and that @tv[0/i] = Top@.
endsInSizedCo :: Int -> TVal -> TypeCheck ()
endsInSizedCo :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo = Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
True

-- | @endsInSizedCo' False i tv@ checks that @tv@ is lower semi-continuous in @i@.
--   @endsInSizedCo' True i tv@ additionally checks that @tv[0/i] = Top@.
endsInSizedCo' :: Bool -> Int -> TVal -> TypeCheck ()
endsInSizedCo' :: Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
i TVal
tv  = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"endsInSizedCo:" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ do
   TVal
tv <- TVal -> TypeCheck TVal
force TVal
tv
   let fallback :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback
         | Bool
endInCo = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"endsInSizedCo: target" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"of corecursive function is neither a CoSet or codata of size" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Int -> TVal
VGen Int
i) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"nor a tuple type"
         | Bool
otherwise = Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szMonotone Int
i TVal
tv
   case TVal
tv of
      VSort (CoSet (VGen Int
i)) -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      VMeasured Measure TVal
mu TVal
bv -> Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
i TVal
bv

      -- case forall j <= i. C j coinductive in i
      VQuant PiSigma
Pi Name
x dom :: Domain
dom@Domain{ typ :: forall a. Dom a -> a
typ = VBelow LtLe
Le (VGen Int
i') } TVal
fv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' ->
        Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
j TVal
xv TVal
bv ->
          Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
j TVal
bv
      VGuard (Bound LtLe
Le (Measure [VGen Int
j]) (Measure [VGen Int
i'])) TVal
bv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' ->
        Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
j TVal
bv

      -- same case again, written as j < i+1. C j
      VQuant PiSigma
Pi Name
x dom :: Domain
dom@Domain{ typ :: forall a. Dom a -> a
typ = VBelow LtLe
Lt (VSucc (VGen Int
i')) } TVal
fv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' ->
        Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
j TVal
xv TVal
bv ->
          Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
j TVal
bv
      VGuard (Bound LtLe
Lt (Measure [VGen Int
j]) (Measure [VSucc (VGen Int
i')])) TVal
bv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' ->
        Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
j TVal
bv

      -- case forall j < i. C j:  already coinductive in i !!
      -- Trivially, forall j < 0. C j is the top type.
      -- And, forall i < # forall j < i  is equivalent to forall j < #
      -- so we can instantiate i to #.
      VGuard (Bound LtLe
Lt (Measure [VGen Int
j]) (Measure [VGen Int
i'])) TVal
bv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' ->
        () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      VQuant PiSigma
Pi Name
x dom :: Domain
dom@Domain{ typ :: forall a. Dom a -> a
typ = VBelow LtLe
Lt (VGen Int
i') } TVal
fv | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> do
         Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lowerSemiContinuous Int
i (TVal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Domain -> TVal
forall a. Dom a -> a
typ Domain
dom
         Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
xv TVal
bv -> Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
i TVal
bv

      VSing TVal
_ TVal
tv -> Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
i (TVal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TypeCheck TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVal -> TypeCheck TVal
whnfClos TVal
tv
      VApp (VDef (DefId IdKind
DatK QName
n)) [TVal]
vl -> do
         SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
         case SigDef
sige of
            DataSig { numPars :: SigDef -> Int
numPars = Int
np, isSized :: SigDef -> Sized
isSized = Sized
Sized, isCo :: SigDef -> Co
isCo = Co
CoInd }
              | [TVal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TVal]
vl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
np -> do
                 TVal
v <- TVal -> TypeCheck TVal
whnfClos (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ [TVal]
vl [TVal] -> Int -> TVal
forall a. HasCallStack => [a] -> Int -> a
!! Int
np
                 if TVal -> Bool
isVGeni TVal
v then () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return () else StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback
                   where isVGeni :: TVal -> Bool
isVGeni (VGen Int
i) = Bool
True
                         isVGeni (VPlus [TVal]
vs) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (TVal -> Bool) -> [TVal] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TVal -> Bool
isVGeni [TVal]
vs
                         isVGeni (VMax [TVal]
vs)  = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (TVal -> Bool) -> [TVal] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TVal -> Bool
isVGeni [TVal]
vs
                         isVGeni TVal
VZero = Bool
True
                         isVGeni TVal
_ = Bool
False
{- WE DO NOT HAVE SUBST ON VALUES!
                 case vl !! np of
                   VGen j -> if i == j then return () else fail1
                   VZero -> return ()
                   VClos rho e -> do
                     v <- whnf (update rho i VZero) e -- BUGGER
                     if v == VZero then return () else fail1
-}
-- we also allow the target to be a tuple if all of its components
-- fulfill "endsInSizedCo"
            DataSig { symbTyp :: SigDef -> TVal
symbTyp = TVal
dv, constructors :: SigDef -> [ConstructorInfo]
constructors = [ConstructorInfo]
cis, isTuple :: SigDef -> Bool
isTuple = Bool
True } -> do
              TVal
-> [TVal]
-> TVal
-> [ConstructorInfo]
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
allTypesOfTuple TVal
tv [TVal]
vl TVal
dv [ConstructorInfo]
cis (Bool
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo' Bool
endInCo Int
i)
{-
              -- match target of constructor against tv to instantiate
              --  c : ... -> D ps  -- ps = snd (cPatFam ci)
              mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis
              case mrhoci of
                Nothing -> failDoc $ text "endsInSizedCo: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor"
                Just (rho,ci) -> enter ("endsInSizedCo: detected tuple target, checking components") $
                  fieldsEndInSizedCo endInCo i (cFields ci) rho
-}
            SigDef
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback
      TVal
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback
{- failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a function type nor a codata nor a tuple type"
-}

-- | @allTypesOfTyples args dv cis check@ performs @check@ on all component
--   types of tuple type @tv = d args@ where @dv@ is the type of @d@.
allTypesOfTuple :: TVal -> [Val] -> TVal -> [ConstructorInfo] -> (TVal -> TypeCheck ()) -> TypeCheck ()
allTypesOfTuple :: TVal
-> [TVal]
-> TVal
-> [ConstructorInfo]
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
allTypesOfTuple TVal
tv [TVal]
vl TVal
dv [ConstructorInfo]
cis TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
check = do
  -- match target of constructor against tv to instantiate
  --  c : ... -> D ps  -- ps = snd (cPatFam ci)
  Maybe (Env, ConstructorInfo)
mrhoci <- [StateT
   TCState
   (ReaderT TCContext (ExceptT TraceError IO))
   (Maybe (Env, ConstructorInfo))]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Env, ConstructorInfo))
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
Util.firstJustM ([StateT
    TCState
    (ReaderT TCContext (ExceptT TraceError IO))
    (Maybe (Env, ConstructorInfo))]
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo)))
-> [StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo))]
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Env, ConstructorInfo))
forall a b. (a -> b) -> a -> b
$
    (ConstructorInfo
 -> StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo)))
-> [ConstructorInfo]
-> [StateT
      TCState
      (ReaderT TCContext (ExceptT TraceError IO))
      (Maybe (Env, ConstructorInfo))]
forall a b. (a -> b) -> [a] -> [b]
map (\ ConstructorInfo
ci -> (Env -> (Env, ConstructorInfo))
-> Maybe Env -> Maybe (Env, ConstructorInfo)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,ConstructorInfo
ci) (Maybe Env -> Maybe (Env, ConstructorInfo))
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Maybe (Env, ConstructorInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Env
-> [Pattern]
-> [TVal]
-> TVal
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
nonLinMatchList Bool
False Env
forall a. Environ a
emptyEnv ((PatternsType, [Pattern]) -> [Pattern]
forall a b. (a, b) -> b
snd ((PatternsType, [Pattern]) -> [Pattern])
-> (PatternsType, [Pattern]) -> [Pattern]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> (PatternsType, [Pattern])
cPatFam ConstructorInfo
ci) [TVal]
vl TVal
dv) [ConstructorInfo]
cis
  -- we know that only one constructor can match, otherwise it would not be a tuple type
  case Maybe (Env, ConstructorInfo)
mrhoci of
    Maybe (Env, ConstructorInfo)
Nothing -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"allTypesOfTuple: panic: target type" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"is not an instance of any constructor"
    Just (Env
rho,ConstructorInfo
ci) -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"allTypesOfTuple: detected tuple target, checking components") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
      [FieldInfo]
-> Env
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
allComponentTypes (ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci) Env
rho TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
check

{-
fieldsEndInSizedCo :: Bool -> Int -> [FieldInfo] -> Env -> TypeCheck ()
fieldsEndInSizedCo endInCo i fis rho0 = allComponentTypes fis rho0 (endsInSizedCo' endInCo i)
fieldsEndInSizedCo endInCo i fis rho0 = enter ("fieldsEndInSizedCo: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $
  loop fis rho0 where
    loop [] rho = return ()
    -- nothing to check for erased index fields
    loop (f : fs) rho | fClass f == Index && erased (fDec f) =
      loop fs rho
    loop (f : fs) rho | fClass f == Index = do
      tv <- whnf rho (fType f)
      endsInSizedCo' endInCo i tv
      loop fs rho
    loop (f : fs) rho = do
      tv <- whnf rho (fType f)
      when (not $ erased (fDec f)) $ endsInSizedCo' endInCo i tv
      -- for non-index fields, value is not given by matching, so introduce
      -- generic value
      new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do
        let rho' = update rho (fName f) xv
        -- do not need to check erased fields?
        loop fs rho'
-}

-- | @allComponentTypes fis env check@ applies @check@ to all field types
--   in @fis@ (evaluated wrt to environment @env@).
--   Erased fields are skipped.  (Is this correct?)
allComponentTypes :: [FieldInfo] -> Env -> (TVal -> TypeCheck ()) -> TypeCheck ()
allComponentTypes :: [FieldInfo]
-> Env
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
allComponentTypes [FieldInfo]
fis Env
rho0 TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
check = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"allComponentTypes: checking fields of tuple type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [FieldInfo] -> String
forall a. Show a => a -> String
show [FieldInfo]
fis String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in environment " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Env -> String
forall a. Show a => a -> String
show Env
rho0) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
  [FieldInfo]
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [FieldInfo]
fis Env
rho0 where
    loop :: [FieldInfo]
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [] Env
rho = () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- nothing to check for erased index fields
    loop (FieldInfo
f : [FieldInfo]
fs) Env
rho | FieldInfo -> FieldClass
fClass FieldInfo
f FieldClass -> FieldClass -> Bool
forall a. Eq a => a -> a -> Bool
== FieldClass
Index Bool -> Bool -> Bool
&& Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased (FieldInfo -> Dec
fDec FieldInfo
f) =
      [FieldInfo]
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [FieldInfo]
fs Env
rho

    -- ordinary index field types are checked
    loop (FieldInfo
f : [FieldInfo]
fs) Env
rho | FieldInfo -> FieldClass
fClass FieldInfo
f FieldClass -> FieldClass -> Bool
forall a. Eq a => a -> a -> Bool
== FieldClass
Index = do
      TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
check (TVal
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TypeCheck TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Expr -> TypeCheck TVal
whnf Env
rho (FieldInfo -> Expr
fType FieldInfo
f)
      [FieldInfo]
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [FieldInfo]
fs Env
rho

    -- proper fields
    loop (FieldInfo
f : [FieldInfo]
fs) Env
rho = do
      TVal
tv <- Env -> Expr -> TypeCheck TVal
whnf Env
rho (FieldInfo -> Expr
fType FieldInfo
f)
      -- do not need to check erased fields?
      Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased (FieldInfo -> Dec
fDec FieldInfo
f)) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
check TVal
tv
      -- for non-index fields, value is not given by matching, so introduce
      -- generic value
      Name
-> Domain
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (TVal -> m a) -> m a
new (FieldInfo -> Name
fName FieldInfo
f) (TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
tv Kind
defaultKind (FieldInfo -> Dec
fDec FieldInfo
f)) ((TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ TVal
xv -> do
        [FieldInfo]
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [FieldInfo]
fs (Env
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Env -> Name -> TVal -> Env
forall a. Environ a -> Name -> a -> Environ a
update Env
rho (FieldInfo -> Name
fName FieldInfo
f) TVal
xv



endsInCo :: TVal -> TypeCheck Bool
endsInCo :: TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
endsInCo TVal
tv  = -- traceCheck ("endsInCo: " ++ show tv) $
   case TVal
tv of
      VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
_ TVal
bv -> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
endsInCo TVal
bv

      VApp (VDef (DefId IdKind
DatK QName
n)) [TVal]
vl -> do
         SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
         case SigDef
sige of
            DataSig { isCo :: SigDef -> Co
isCo = Co
CoInd } -> -- traceCheck ("found non-sized coinductive target") $
               Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            SigDef
_ -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      TVal
_ -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- precondition: Pattern does not contain "Unusable"
admPattern :: Pattern -> TVal -> TypeCheck (Pattern, [Co])
admPattern :: Pattern -> TVal -> TypeCheck (Pattern, [Co])
admPattern Pattern
p TVal
tv = String -> TypeCheck (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a. String -> a -> a
traceAdm (String
"admPattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv) (TypeCheck (Pattern, [Co]) -> TypeCheck (Pattern, [Co]))
-> TypeCheck (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a b. (a -> b) -> a -> b
$
  case TVal
tv of
      VGuard Bound TVal
beta TVal
bv -> Bound TVal
-> TypeCheck (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a.
Bound TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bound TVal -> m a -> m a
addBoundHyp Bound TVal
beta (TypeCheck (Pattern, [Co]) -> TypeCheck (Pattern, [Co]))
-> TypeCheck (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a b. (a -> b) -> a -> b
$ Pattern -> TVal -> TypeCheck (Pattern, [Co])
admPattern Pattern
p TVal
bv
      VApp (VDef (DefId IdKind
DatK QName
d)) [TVal]
vl -> do
         case Pattern
p of
           ProjP Name
n -> (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern
p, [])
           Pattern
_ -> String -> TypeCheck (Pattern, [Co])
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
"admPattern: IMPOSSIBLE: non-projection pattern for record type"
      VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck (Pattern, [Co]))
-> TypeCheck (Pattern, [Co])
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int -> TVal -> TVal -> TypeCheck (Pattern, [Co]))
 -> TypeCheck (Pattern, [Co]))
-> (Int -> TVal -> TVal -> TypeCheck (Pattern, [Co]))
-> TypeCheck (Pattern, [Co])
forall a b. (a -> b) -> a -> b
$ \ Int
k TVal
xv TVal
bv -> do
  {-
         if p is successor pattern
         check that bv is admissible in k, returning subset of [Ind, CoInd]
         p is usable if either CoInd or it is a var or dot pattern and Ind
-}
         if Pattern -> Bool
isSuccessorPattern Pattern
p then do
           [Co]
inco <- Int -> TVal -> TypeCheck [Co]
admType Int
k TVal
bv
           Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Co
CoInd Co -> [Co] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Co]
inco Bool -> Bool -> Bool
&& Bool -> Bool
not (Pattern -> Bool
shallowSuccP Pattern
p)) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Pattern
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
cannotMatchDeep Pattern
p TVal
tv
           if (Co
CoInd Co -> [Co] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Co]
inco)
              Bool -> Bool -> Bool
|| ([Co]
inco [Co] -> [Co] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& Pattern -> Bool
completeP Pattern
p)
            then (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern
p, [Co]
inco)
            else (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Pattern
forall e. Pat e -> Pat e
UnusableP Pattern
p, [Co]
inco)
          else (Pattern, [Co]) -> TypeCheck (Pattern, [Co])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern
p, [])

      TVal
_ -> String -> TypeCheck (Pattern, [Co])
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
"admPattern: IMPOSSIBLE: pattern for a non-function type"

cannotMatchDeep :: Pattern -> TVal -> TypeCheck ()
cannotMatchDeep :: Pattern
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
cannotMatchDeep Pattern
p TVal
tv = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => m Doc -> m ()
recoverFailDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
  String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"cannot match against deep successor pattern"
    StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text (Pattern -> String
forall a. Show a => a -> String
show Pattern
p) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"at type" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM TVal
tv

admType :: Int -> TVal -> TypeCheck [Co]
admType :: Int -> TVal -> TypeCheck [Co]
admType Int
i TVal
tv = String -> TypeCheck [Co] -> TypeCheck [Co]
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"admType: checking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" admissible in v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) (TypeCheck [Co] -> TypeCheck [Co])
-> TypeCheck [Co] -> TypeCheck [Co]
forall a b. (a -> b) -> a -> b
$
    case TVal
tv of
       VQuant PiSigma
Pi Name
x dom :: Domain
dom@(Domain TVal
av Kind
_ Dec
_) TVal
fv -> do
          Bool
isInd <- Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
szUsed Co
Ind Int
i TVal
av
          Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isInd) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
            Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szAntitone Int
i TVal
av StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> m Doc -> m a
`newErrorDoc` Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
docNotLowerSemi Int
i TVal
av
          Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck [Co])
-> TypeCheck [Co]
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int -> TVal -> TVal -> TypeCheck [Co]) -> TypeCheck [Co])
-> (Int -> TVal -> TVal -> TypeCheck [Co]) -> TypeCheck [Co]
forall a b. (a -> b) -> a -> b
$ \ Int
gen TVal
_ TVal
bv -> do
            [Co]
inco <- Int -> TVal -> TypeCheck [Co]
admType Int
i TVal
bv
            if Bool
isInd then [Co] -> TypeCheck [Co]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Co
Ind Co -> [Co] -> [Co]
forall a. a -> [a] -> [a]
: [Co]
inco) else [Co] -> TypeCheck [Co]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Co]
inco
       TVal
_ -> do
          Bool
isCoind <- Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
szUsed Co
CoInd  Int
i TVal
tv
          if Bool
isCoind then [Co] -> TypeCheck [Co]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Co
CoInd]
           else do
            Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szMonotone Int
i TVal
tv
            [Co] -> TypeCheck [Co]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []

szUsed :: Co -> Int -> TVal -> TypeCheck Bool
szUsed :: Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
szUsed Co
co Int
i TVal
tv = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. String -> a -> a
traceAdm (String
"szUsed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Co -> String
forall a. Show a => a -> String
show Co
co String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$
    case TVal
tv of
         (VApp (VDef (DefId IdKind
DatK QName
n)) [TVal]
vl) -> do
                String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceAdmM (String
"szUsed: case data type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TVal] -> String
forall a. Show a => a -> String
show [TVal]
vl)
                SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
                case SigDef
sige of
                  DataSig { numPars :: SigDef -> Int
numPars = Int
p
                          , isSized :: SigDef -> Sized
isSized = Sized
Sized
                          , isCo :: SigDef -> Co
isCo = Co
co' } | Co
co Co -> Co -> Bool
forall a. Eq a => a -> a -> Bool
== Co
co' Bool -> Bool -> Bool
&& [TVal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TVal]
vl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p ->
                      -- p is the number of parameters
                      -- it is also the index of the size argument
                      do TVal
s <- TVal -> TypeCheck TVal
whnfClos (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ [TVal]
vl [TVal] -> Int -> TVal
forall a. HasCallStack => [a] -> Int -> a
!! Int
p
                         case TVal
s of
                           VGen Int
i' | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           TVal
_ -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  SigDef
_ -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
         TVal
_ -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False



-- for inductive fun, and for every size argument i
-- - every argument needs to be either inductive or antitone in i
-- - the result needs to be monotone in i

{- szCheckIndFun admpos delta tv

 entry point for admissibility check for recursive functions
 - scans for the first size quantification
 - passes on to szCheckIndFunSize
 - currently: also continues to look for the next size quantification...
 -}

szCheckIndFun :: [Int] -> TVal -> TypeCheck ()
szCheckIndFun :: [Int]
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szCheckIndFun [Int]
admpos TVal
tv = -- traceCheck ("szCheckIndFun: " ++ show delta ++ " |- " ++ show tv ++ " adm?") $
      case TVal
tv of
       VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
k TVal
_ TVal
bv -> do
         -- bv <- whnf' b
         if TVal -> Bool
isVSize (Domain -> TVal
forall a. Dom a -> a
typ Domain
dom) then do
             Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
admpos) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
               Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szCheckIndFunSize Int
k TVal
bv
             [Int]
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szCheckIndFun [Int]
admpos TVal
bv -- this is for lexicographic induction on sizes, I suppose?  Probably should me more fine grained!  Andreas, 2008-12-01
          else [Int]
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szCheckIndFun [Int]
admpos TVal
bv
       TVal
_ -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


{- szCheckIndFunSize delta i tv

 checks whether type tv is admissible for recursion in index i
 - every argument needs to be either inductive or antitone in i
 - the result needs to be monotone in i
 -}

szCheckIndFunSize :: Int -> TVal -> TypeCheck ()
szCheckIndFunSize :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szCheckIndFunSize Int
i TVal
tv = -- traceCheck ("szCheckIndFunSize: " ++ show delta ++ " |- " ++ show tv ++ " adm(v" ++ show i ++ ")?") $
    case TVal
tv of
       VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> do
            Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szLowerSemiCont Int
i (Domain -> TVal
forall a. Dom a -> a
typ Domain
dom)
--            new x dom $ \ k _  -> szCheckIndFunSize i =<< app fv (VGen k)
            Name
-> Domain
-> TVal
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int
  -> TVal
  -> TVal
  -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Int
    -> TVal
    -> TVal
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
_ TVal
bv -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szCheckIndFunSize Int
i TVal
bv
{-
            new' x dom $ do
              bv <- whnf' b
              szCheckIndFunSize i bv
-}
       TVal
_ -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szMonotone Int
i TVal
tv

{- szLowerSemiCont

 - check for lower semi-continuity [Abel, CSL 2006]
 - current approximation: inductive type or antitone
 -}
szLowerSemiCont :: Int -> TVal -> TypeCheck ()
szLowerSemiCont :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szLowerSemiCont Int
i TVal
av = -- traceCheck ("szlowerSemiCont: checking " ++ show av ++ " lower semi continuous in v" ++ show i) $
   (Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szAntitone Int
i TVal
av StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> (TraceError
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (TraceError
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
      (\ TraceError
msg -> -- traceCheck (show msg) $
                   Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szInductive Int
i TVal
av))
        StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> m Doc -> m a
`newErrorDoc` Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
docNotLowerSemi Int
i TVal
av


{- checking cofun-types for admissibility

conditions:

1. type must end in coinductive type or in sized coinductive type
   indexed by just a variable i which has been quantified in the type

2. in the second case, each argument must be inductive or antitone in i
   optimization:
     arguments types before the quantification over i can be ignored
-}

data CoFunType
  = CoFun             -- yes, but not sized cotermination
  | SizedCoFun Int    -- yes an admissible sized type (the Int specifies the number of the recursive size argument)

{-
design:

admCoFun delta tv : IsCoFunType

   endsInCo delta tv (len delta) id

admEndsInCo delta tv firstVar jobs : IsCoFunType

   traverse tv, gather continutations in jobs, check for CoInd in the end

   if tv = (x:A) -> B
      push A on delta
      add the following task to jobs:
        check A for lower semicontinuity in delta
      continue on B

   if tv = Codata^i
      run (jobs i)
      if they return (), return YesSized Int, otherwise No

   if tv = Codata
      return Yes

   otherwise
      return No
 -}

-- {- TODO: FINISH THIS!!

admCoFun :: TVal -> TypeCheck CoFunType
admCoFun :: TVal -> TypeCheck CoFunType
admCoFun TVal
tv = do
  Int
l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
  TVal
-> Int
-> (Int
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TypeCheck CoFunType
admEndsInCo TVal
tv Int
l (\ Int
i -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

admEndsInCo :: TVal -> Int -> (Int -> TypeCheck ()) -> TypeCheck CoFunType
admEndsInCo :: TVal
-> Int
-> (Int
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TypeCheck CoFunType
admEndsInCo TVal
tv Int
firstVar Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
jobs = -- traceCheck ("admEndsInCo: " ++ show tv) $
   case TVal
tv of
      VQuant PiSigma
Pi Name
x Domain
dom TVal
fv -> do
         Int
l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
         let jobs' :: Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
jobs' = (Int
-> TVal
-> (Int
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
addJob Int
l (Domain -> TVal
forall a. Dom a -> a
typ Domain
dom) Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
jobs)
         Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck CoFunType)
-> TypeCheck CoFunType
forall a.
Name
-> Domain
-> TVal
-> (Int -> TVal -> TVal -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom TVal
fv ((Int -> TVal -> TVal -> TypeCheck CoFunType)
 -> TypeCheck CoFunType)
-> (Int -> TVal -> TVal -> TypeCheck CoFunType)
-> TypeCheck CoFunType
forall a b. (a -> b) -> a -> b
$ \ Int
_ TVal
_ TVal
bv -> TVal
-> Int
-> (Int
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> TypeCheck CoFunType
admEndsInCo TVal
bv Int
firstVar Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
jobs'
{-
         new' x dom $ do
           bv <- whnf' b
           admEndsInCo bv firstVar jobs'
-}

{-
      -- if not applied, it cannot be a sized type
      VDef n -> do
         sig <- gets signature
         case (lookupSig n sig) of
            DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $
               return CoFun
            _ -> throwErrorMsg $ "type of cofun does not end in coinductive type"
-}

      VApp (VDef (DefId IdKind
DatK QName
n)) [TVal]
vl -> do
         SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
         case SigDef
sige of
            DataSig { isSized :: SigDef -> Sized
isSized = Sized
NotSized, isCo :: SigDef -> Co
isCo = Co
CoInd } -> -- traceCheck ("found non-sized coinductive target") $
               CoFunType -> TypeCheck CoFunType
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoFunType
CoFun
            DataSig { numPars :: SigDef -> Int
numPars = Int
p, isSized :: SigDef -> Sized
isSized = Sized
Sized, isCo :: SigDef -> Co
isCo = Co
CoInd } | [TVal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TVal]
vl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p -> -- traceCheck ("found sized coinductive target") $
              do
               -- p is the number of parameters
               -- it is also the index of the size argument
               TVal
s <- TVal -> TypeCheck TVal
whnfClos (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ [TVal]
vl [TVal] -> Int -> TVal
forall a. HasCallStack => [a] -> Int -> a
!! Int
p
               case TVal
s of
                  VGen Int
i -> do
                     Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
jobs Int
i
                     CoFunType -> TypeCheck CoFunType
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoFunType -> TypeCheck CoFunType)
-> CoFunType -> TypeCheck CoFunType
forall a b. (a -> b) -> a -> b
$ Int -> CoFunType
SizedCoFun (Int -> CoFunType) -> Int -> CoFunType
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstVar
                  TVal
_ -> String -> TypeCheck CoFunType
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck CoFunType) -> String -> TypeCheck CoFunType
forall a b. (a -> b) -> a -> b
$ String
"size argument in result type must be a variable"
            SigDef
_ -> String -> TypeCheck CoFunType
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck CoFunType) -> String -> TypeCheck CoFunType
forall a b. (a -> b) -> a -> b
$ String
"type of cofun does not end in coinductive type"

addJob :: Int -> TVal -> (Int -> TypeCheck ())
       -> (Int -> TypeCheck ())
addJob :: Int
-> TVal
-> (Int
    -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
addJob Int
l TVal
tv Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
jobs Int
recVar = do
  -- is the "recursive" size variable actually in scope?
  Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
jobs Int
recVar
  Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
recVar Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szLowerSemiCont Int
recVar TVal
tv

-- -}


{- szCheckCoFun  OBSOLETE!!

 entry point for admissibility check for corecursive functions
 - scans for the first size quantification
 - passes on to szCheckIndFunSize
 - currently: also continues to look for the next size quantification
 - and checks in the end whether the target is a coinductive type


-- STALE COMMENT: for a cofun : arguments nocc i and result coinductive in i
szCheckCoFun :: SemCxt -> TVal -> TypeCheck ()
szCheckCoFun delta tv =
      case tv of
       VPi dec x av env b -> do
                let (k, delta') = cxtPush dec av delta
                bv <- whnf (update env x (VGen k)) b
                case av of
                  VSize -> do szCheckCoFunSize delta' k bv
                              szCheckCoFun delta' bv
                  _ -> szCheckCoFun delta' bv
       -- result
       (VApp (VDef n) vl) ->
          do sig <- gets signature
             case (lookupSig n sig) of
               (DataSig _ _ _ CoInd _) ->
                   return ()
               _ -> throwErrorMsg $ "cofun doesn't target coinductive type"
       (VDef n)  ->
          do sig <- gets signature
             case (lookupSig n sig) of
               (DataSig _ _ _ CoInd _) ->
                   return ()
               _ -> throwErrorMsg $ "cofun doesn't target coinductive type"
       _ -> throwErrorMsg $ "cofun doesn't target coinductive type"

szCheckCoFunSize :: SemCxt -> Int -> TVal -> TypeCheck ()
szCheckCoFunSize delta i tv = -- traceCheck ("szco " ++ show tv) $
      case tv of
       VPi dec x av env b ->  do
             let (k, delta') = cxtPush dec av delta
             bv <- whnf (update env x (VGen k)) b
             szLowerSemiCont delta i av
             szCheckCoFunSize delta' i bv
       -- result must be coinductive
       _ -> szCoInductive delta i tv

-}

szMono :: Co -> Int -> TVal -> TypeCheck ()
szMono :: Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szMono Co
co Int
i TVal
tv =
    case Co
co of
         Co
Ind   -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szMonotone Int
i TVal
tv
         Co
CoInd -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szAntitone Int
i TVal
tv

szMonotone :: Int -> TVal -> TypeCheck ()
szMonotone :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szMonotone Int
i TVal
tv = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. String -> a -> a
traceCheck (String
"szMonotone: " -- ++ show delta ++ " |- "
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" mon(v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")?") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
 do
   let si :: TVal
si = TVal -> TVal
VSucc (Int -> TVal
VGen Int
i)
   TVal
tv' <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute (Int -> TVal -> Substitution
sgSub Int
i TVal
si) TVal
tv
   Pol
-> TVal
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal Pol
Pos TVal
vTopSort TVal
tv TVal
tv'

szAntitone :: Int -> TVal -> TypeCheck ()
szAntitone :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szAntitone Int
i TVal
tv = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. String -> a -> a
traceCheck (String
"szAntitone: " -- ++ show delta ++ " |- "
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ TVal -> String
forall a. Show a => a -> String
show TVal
tv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" anti(v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")?") (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
 do
   let si :: TVal
si = TVal -> TVal
VSucc (Int -> TVal
VGen Int
i)
   TVal
tv' <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute (Int -> TVal -> Substitution
sgSub Int
i TVal
si) TVal
tv
   Pol
-> TVal
-> TVal
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal Pol
Neg TVal
vTopSort TVal
tv TVal
tv'

-- checks if tv is a sized inductive type of size i
szInductive :: Int -> TVal -> TypeCheck ()
szInductive :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szInductive Int
i TVal
tv = Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szUsed' Co
Ind Int
i TVal
tv

-- checks if tv is a sized coinductive type of size i
szCoInductive :: Int -> TVal -> TypeCheck ()
szCoInductive :: Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szCoInductive Int
i TVal
tv = Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szUsed' Co
CoInd Int
i TVal
tv

szUsed' :: Co -> Int -> TVal -> TypeCheck ()
szUsed' :: Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
szUsed' Co
co Int
i TVal
tv =
    case TVal
tv of
         (VApp (VDef (DefId IdKind
DatK QName
n)) [TVal]
vl) ->
             do SigDef
sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
                case SigDef
sige of
                  DataSig { numPars :: SigDef -> Int
numPars = Int
p, isSized :: SigDef -> Sized
isSized = Sized
Sized, isCo :: SigDef -> Co
isCo =  Co
co' } | Co
co Co -> Co -> Bool
forall a. Eq a => a -> a -> Bool
== Co
co' Bool -> Bool -> Bool
&& [TVal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TVal]
vl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p ->
                      -- p is the number of parameters
                      -- it is also the index of the size argument
                      do TVal
s <- TVal -> TypeCheck TVal
whnfClos (TVal -> TypeCheck TVal) -> TVal -> TypeCheck TVal
forall a b. (a -> b) -> a -> b
$ [TVal]
vl [TVal] -> Int -> TVal
forall a. HasCallStack => [a] -> Int -> a
!! Int
p
                         case TVal
s of
                           VGen Int
i' | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i' -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                           TVal
_ -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"expected size variable"
                  SigDef
_ -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"expected (co)inductive sized type"
         TVal
_ -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
 -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"expected (co)inductive sized type"