{-# 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
  de  <- Declaration -> TypeCheck [Declaration]
typeCheckDeclaration Declaration
d
  dse <- typeCheckDecls ds
  return (de ++ 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
  st <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TCState
forall s (m :: * -> *). MonadState s m => m s
get
  _ <- typeCheckDecls ds
  put st             -- forget the effect of these decls
  return []
typeCheckDeclaration (OverrideDecl Override
Fail [Declaration]
ds) = do
  st <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TCState
forall s (m :: * -> *). MonadState s m => m s
get
  r <- (typeCheckDecls ds >> return True) `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 r then throwErrorMsg "unexpected success" else do
    put st
    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
    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
    checkPositivityGraph
    return 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
    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
    checkPositivityGraph
    return 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
-}
  (vt, te, Kinded ki ee) <- Dec
-> Telescope
-> Maybe Expr
-> Expr
-> TypeCheck (TVal, Expr, Kinded Expr)
checkLetDef Dec
neutralDec Telescope
tel Maybe Expr
mt Expr
e
  rho <- getEnv -- is emptyEnv
  -- TODO: solve size constraints
  -- does not work with emptyEnv
  -- [te, ee] <- solveAndModify [te, ee] rho  -- solve size constraints
  let v = Env -> Expr -> TVal
mkClos Env
rho Expr
ee -- delay whnf computation
  -- v  <- whnf' ee -- WAS: whnf' e'
  addSig n (LetSig vt ki v $ undefinedFType $ QName n)    -- late (var -> expr) binding, but ok since no shadowing
--  addSig n (LetSig vt e')    -- late (var -> expr) binding, but ok since no shadowing
  echoKindedTySig ki n te
--  echoTySigE n te
--  echoDefE   n ee
  echoKindedDef ki n ee
  return [LetDecl eval n emptyTel (Just te) 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
  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
  addSig x (PatSig xs p v)
  return [d]

typeCheckDeclaration (MutualFunDecl Bool
False Co
co [Fun]
funs) =
  -- traceCheck ("type checking a function block") $
  do
    funse <- Co -> [Fun] -> TypeCheck [Fun]
typeCheckFuns Co
co [Fun]
funs
    return $ [MutualFunDecl False co funse]

typeCheckDeclaration (MutualFunDecl Bool
True Co
co [Fun]
funs) =
  -- traceCheck ("type checking a block of measured function") $
  do
    funse <- Co -> [Fun] -> TypeCheck [Fun]
typeCheckMeasuredFuns Co
co [Fun]
funs
    return $ [MutualFunDecl False co funse]

typeCheckDeclaration (MutualDecl Bool
measured [Declaration]
ds) = do
  -- first check type signatures
  -- we add the typings into the context, not the signature
  ktss <- [Declaration] -> TypeCheck [Kinded (TySig TVal)]
typeCheckMutualSigs [Declaration]
ds
  -- register the mutually defined names
  let 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 = (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
  edss <- addKindedTypeSigs ktss $ addMutualNames $
    zipWithM (typeCheckMutualBody measured) (map (predKind . kindOf) ktss) ds
  -- check and reset positivity graph
  checkPositivityGraph
  return $ concat 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 ki (TypeSig n tv)) <- Declaration -> TypeCheck (Kinded (TySig TVal))
typeCheckMutualSig Declaration
d
  new' n (Domain tv ki defaultDec) $ do
    ktss <- typeCheckMutualSigs ds
    return $ kts : 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 ki te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
  tv <- whnf' te
  return $ Kinded (predKind ki) $ TypeSig n 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 ki 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))
  return $ Kinded ki 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' <- Co -> Kind -> Fun -> TypeCheck Fun
typeCheckFunBody Co
co Kind
ki Fun
fun
    return $ [FunDecl co 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.
     (p', pos, 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
           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
           return (params + 1, pos0 ++ [polsz], 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 = (Telescope -> Expr -> Expr
teleToType Telescope
tel0 Expr
t)
     echoTySig n 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 ki0 (ds, dte) <- checkDataType p' dt -- TODO?: use above code?
     let ki = Kind -> Kind
dataKind Kind
ki0
     echoKindedTySig ki n dte
--     echoTySigE n dte
     v <- whnf emptyEnv dte
     Just fkind <- extractKind v
     -- get the updated telescope which contains the kinds
     let (tel, dtcore) = typeToTele' params dte
     -- compute the constructor telescopes
     cs0 <- mapM (insertConstructorTele tel dtcore) cs0
     let cis = Co -> Name -> Telescope -> [Constructor] -> [ConstructorInfo]
analyzeConstructors Co
co Name
n Telescope
tel [Constructor]
cs0
     let cs  = (ConstructorInfo -> Constructor)
-> [ConstructorInfo] -> [Constructor]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Constructor
reassembleConstructor [ConstructorInfo]
cis
     addSig n (DataSig { numPars = params
                       , positivity = pos
                       , isSized = sz
                       , isCo = co
                       , symbTyp = v
                       , symbolKind = ki
                       , constructors = cis
                       , etaExpand = False
                       , isTuple = 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 = fkind
                       })
     when (sz == Sized) $
           szType co params v

     (isRecList, kcse) <- liftM unzip $
       mapM (typeCheckConstructor n dte sz co pos tel) cs

     -- compute the kind of the data type from the kinds of the
     -- constructor arguments  (mmh, DOES NOT WORK FOR MUTUAL DATA!)
     let 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
     sol <- solveConstraints
     -- TODO: substitute
     resetConstraints

     -- add destructors only for the constructors that are non-overlapping
     let 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
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
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
_ -> []

     when (not (null decls)) $
        traceCheckM $ "generated destructors: " ++ show decls
     declse <- 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)
                 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 = (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
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 -> 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
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')
     traceEtaM $ "data " ++ show n ++ " eta-expandable " ++ show typeEtaExpandable ++ " constructors " ++ show cis'
     modifySig n (\ SigDef
dataSig ->
                      SigDef
dataSig { symbolKind = newki
                              , etaExpand = typeEtaExpandable
                              , constructors = cis'
                              , isTuple = length cis' >= 1 && isPatIndFam
                              })
     -- compute extracted data decl
     let (tele, te) = typeToTele' (size tel) dte
     return $ (DataDecl n sz co pos tele te (map valueOf kcse) fields) : concat 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
  res <- Telescope -> Expr -> Expr -> TypeCheck (Telescope, [Pattern])
computeConstructorTele Telescope
dtel Expr
dt Expr
t
  return $ Constructor n (Just res) 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
  (cxt, 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)
  (,ps) . setDec (Dec Param) <$> do local (const cxt) $ contextToTele 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
  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
  ([],_,cxt,_,_,_,False) <- checkPatterns defaultDec [] emptySub tv ps
  return (cxt, 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
      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 dom <- lookupM k delta
      TBind x <$> Traversable.traverse toExpr 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
-}
  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 = 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 = Telescope -> Expr -> Expr
teleToType Telescope
telE Expr
t
  echoTySig n tt
  let 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 = [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 ki te <- addBinds telWithD $
    checkConType sz t -- do NOT resurrect telescope!!

  -- Check target of constructor.
  dv <- whnf' dt
  let (Telescope argts,target) = typeToTele te
  whenNothing mctel $ -- only for old-style parameters
    addBinds telWithD $ addBinds (Telescope argts) $ checkTarget d dv tel target

  -- Make type of a constructor a singleton type.
  let 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 = (TBind -> Name) -> [TBind] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TBind -> Name
forall a. TBinding a -> Name
boundName [TBind]
argts
      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 = (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   = 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  = 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 = Telescope -> Expr -> Expr
teleToType Telescope
telE Expr
tsing -- te -- DO resurrect here!
  vt <- whnf' 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
  -}
  mutualNames <- asks mutualNames
  let 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   = (TBind -> Bool) -> [TBind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TBind -> Bool
mutOcc [TBind]
argts
      isRec     = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
recOccs
  -- fType <- extractType vt -- moved to Extract
  let fType = QName -> Expr
undefinedFType QName
n
  isSz <- if sz /= Sized then return Nothing else do
    szConstructor d co params vt -- check correct use of sizes
    if co == CoInd then return $ Just $ error "impossible lhs type of coconstructor" else do
    let (x, lte) = mapSnd (teleToType telE) $ mkConLType params te
    echoKindedTySig kTerm n lte
    ltv <- whnf' lte
    return $ Just (x, ltv)

  -- Add the type constructor to the signature.
  let 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
  addSigQ n (ConSig cpars isSz recOccs vt d (size dtel) fType)
--  let (tele, te) = typeToTele (length tel) tte -- NOT NECESSARY
  echoKindedTySig kTerm n tte
  -- traceM ("kind of " ++ n ++ "'s args: " ++ show ki)
--  echoTySigE n tte
  return (isRec, Kinded ki $ Constructor n (fmap (mapFst (const telE)) mctel) te)

typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [EFun]
typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [Fun]
typeCheckMeasuredFuns Co
co [Fun]
funs0 = do
    -- echo $ show funs
    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 = (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
    kcle <- installFuns co (zipWith Kinded (map kindOf kfse) funs) $
      mapM typeCheckFunClauses funs
    let 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 = (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 = (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
    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))
      funse
    -- replace in signature by erased clauses
    zipWithM_ (enableSig co) (zipWith intersectKind kis $ map kindOf kfse) funse
    return $ 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
      vt <- Expr -> TypeCheck TVal
whnf' Expr
t
      addSig n (FunSig co vt ki ar' cl' True $ undefinedFType $ QName n)
      -- add a let binding for external use
      v <- up False (vFun n) vt
      addSig n' (LetSig vt ki v $ undefinedFType $ QName 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 ki 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
    echoR $ (PP.render $ prettyFun n clse)
    -- replace in signature by erased clauses
    let fune = TySig Expr -> Name -> Arity -> [Clause] -> Fun
Fun TySig Expr
ts Name
n' Arity
ar [Clause]
clse
    enableSig ki fune
    return fune


typeCheckFuns :: Co -> [Fun] -> TypeCheck [EFun]
typeCheckFuns :: Co -> [Fun] -> TypeCheck [Fun]
typeCheckFuns Co
co [Fun]
funs0 = do
    -- echo $ show funs
    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 (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
    mapM_ (addFunSig co) kfuns
    let 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
    kce <- setCo co $ mapM typeCheckFunClauses funs
    let 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 = (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   = (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!
    clse <- 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') funs clse
    -- replace old clauses by new ones in funs
    let 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
    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))
      funse
    terminationCheck funse
    -- replace in signature by erased clauses
    zipWithM_ enableSig kis funse
    return $ 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
    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
    vt <- whnf' t -- TODO: PROBLEM for internal extraction (would need te here)
    addSig n (FunSig co vt ki ar cl False $ undefinedFType $ QName 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 vt <- Expr -> TypeCheck TVal
whnf' Expr
t
             admFunDef co cls 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 vt ki0 ar cl _ ftyp) <- Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => Name -> m SigDef
lookupSymb Name
n
  addSig n (FunSig co vt (intersectKind ki ki0) ar cl' True ftyp)
  -- add a let binding for external use
  v <- up False (vFun n) vt
  addSig n' (LetSig vt ki v 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 ki0 te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
  -- let te = eraseMeasure te0
  let ki = Kind -> Kind
predKind Kind
ki0
  echoKindedTySig ki n (eraseMeasure te)
--  echoTySigE n te
  return $ Kinded ki $ TypeSig n 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 _ 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
      return 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 ki t2e <- Expr -> TypeCheck (Kinded Expr)
checkConType' Expr
t2
               return $ Kinded ki $ Quant Pi (mapDec (const irrelevantDec) tb) 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
  (s, 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 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
  tv <- Expr -> TypeCheck TVal
whnf' Expr
tg
  case 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
      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
      _ <- enter ("checking datatype parameters in constructor target") $
        leqVals' N mixed (One dv) (take (size tel) vs) telvs
      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
       k <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
       traceCheckM ("length of context = " ++ show k)
       -- t1e <- checkingDom $ if k <= p then checkType t1 else checkSmallType t1
       (s1, Kinded ki0 t1e) <- checkingDom $ inferType t1
       let ki1 = Kind -> Kind
predKind Kind
ki0
       addBind (TBind x (Domain t1 ki1 defaultDec)) $ do
         Kinded ki2 (s, t2e) <- checkDataType p t2
         -- when k <= p $ ltSort s1 s -- check size of indices (disabled)
         return $ Kinded ki2 (s, Quant Pi (TBind x (Domain t1e ki1 dec)) t2e)
     Sort s :: Sort Expr
s@(Set Expr
e1)   -> do
       (_, e1e) <- Expr -> TypeCheck (TVal, Expr)
checkLevel Expr
e1
       return $ Kinded (kUniv e1e) (s, Sort $ Set e1e)
     Sort s :: Sort Expr
s@(CoSet Expr
e1) -> do
       e1e <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e1
       return $ Kinded (kUniv Zero) (s, Sort $ CoSet 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 <- (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
      addMeta ren i
      return 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
      (v, Kinded ki e) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e
      subtype v vSize
      return 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
  e' <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
  v' <- whnf' e
  leSize ltle Pos v' v
  return 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 _ ee <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e TVal
vSize
  v  <- whnf' e
  when (v == VInfty) $ recoverFail $ "# is not a valid universe level"
  return (v, 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
  l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
  enterDoc (text ("checkExpr " ++ show l ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do

   ce <- ask
   traceCheck ("checkExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " : " ++ show v ++ " in env" ++ show (environ ce)) $ do

    (case (e, 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
          (tv, _) <- 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)
          subtype tv vSize
          vx@(VGen i) <- whnf' (Var x)
          endsInSizedCo i v
          let dom = TVal -> Kind -> Dec -> Domain
forall a. a -> Kind -> Dec -> Dom a
Domain TVal
vSize Kind
kSize Dec
defaultDec
          newWithGen y dom $ \ 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 ki2 rhse <- Substitution -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkRHS Substitution
emptySub Expr
rhs TVal
v'
                return $ Kinded ki2 $ Case (Var x) (Just tSize) [Clause [TBind y dom] [SuccP (VarP y)] (Just rhse)]


      (Case Expr
e Maybe Expr
mt [Clause]
cs, TVal
v) -> do
          (tv, t, Kinded ki1 ee) <- Dec -> Expr -> Maybe Expr -> TypeCheck (TVal, Expr, Kinded Expr)
checkOrInfer Dec
neutralDec Expr
e Maybe Expr
mt
          ve <- whnf' ee
          -- tv' <- sing' ee tv -- DOES NOT WORK
          Kinded ki2 cle <- checkCases ve (arrow tv v) cs
          return $ Kinded ki2 $ Case ee (Just t) 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
          (v2, Kinded ki1 ee) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e
          checkSubtype ee v2 v
          return $ Kinded ki1 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
  (v_t1, t1e, Kinded ki1 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
  checkLetBody x t1e v_t1 ki1 dec e1e e2 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.
  (tel, (vt, te, Kinded ki 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
  te <- return $ teleToType tel te
  ee <- return $ teleLam tel ee
  vt <- whnf' te
  return (vt, te, Kinded ki 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
  v_e1 <- Expr -> TypeCheck TVal
whnf' Expr
e1e
  new x (Domain v_t1 ki1 dec) $ \ 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 ki2 e2e <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e2 TVal
v'
      return $ Kinded ki2 $ LLet (TBind x (Domain (Just t1e) ki1 dec)) emptyTel e1e 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
      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
      continue $ if lowerSemi then VBelow Le VInfty else av
    TVal
_ -> TVal -> TypeCheck (Kinded Expr)
continue TVal
av
  where
    continue :: TVal -> TypeCheck (Kinded Expr)
continue TVal
av = do
      Kinded k1 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
      v1 <- whnf' e1
      bv <- app fv v1
      Kinded k2 e2 <- checkExpr e2 bv
      return $ Kinded (unionKind k1 k2) $ Pair (maybeErase dec e1) 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 <- (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
  v   <- force v
--  enter ("checkForced " ++ show ren ++ " |- " ++ show e ++ " : " ++ show v) $ do
  enterDoc (text ("checkForced " ++ show ren ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do
    case (e,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
         mfs <- QName -> [TVal] -> TypeCheck (Maybe [(Name, TVal)])
getFieldsAtType QName
d [TVal]
vl
         case 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
                      tv <- TVal -> TVal -> TypeCheck TVal
piApp TVal
tv TVal
VIrr -- remove record argument (cannot be dependent!)
                      Kinded k e <- checkExpr e tv
                      Kinded k' es <- cont
                      return $ Kinded (unionKind k k') ((p,e) : es)
             Kinded k 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
             return $ Kinded k $ Record ri 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 ki1 e1e <- Expr -> TVal -> TypeCheck (Kinded Expr)
checkExpr Expr
e1 TVal
bv
            -- the kind of a lambda is the kind of its body
            return $ Kinded ki1 $ Lam (decor dom) y 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 xs pat _ <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
c
             let (xs1, xs2) = splitAt (length es) xs
                 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       = (Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi (Pattern -> Expr
patternToExpr Pattern
pat)
                 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
             checkForced e 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
            (v2,kee) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e
            checkSubtype (valueOf kee) v2 v
            return 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 ki 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
        return $ Kinded ki $ Lam (decor dom) y ee
    TVal
_ -> do
      c <- QName -> TVal -> TypeCheck QName
disambigCon QName
c TVal
v
      tv <- conType c v
      (knes, dv) <- checkSpine es tv
      let 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
      checkSubtype ee dv v
      return $ Kinded kTerm 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
  (kne, tv) <- Expr -> TVal -> TypeCheck (Kinded (Name, Expr), TVal)
checkApp Expr
e TVal
tv
  (knes, tv) <- checkSpine es tv
  return (kne : knes, 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
  v <- TVal -> TypeCheck TVal
force TVal
v -- if v is a corecursively defined type in Set, unfold!
  enter ("checkApp " ++ show v ++ " eliminated by " ++ show e2) $ do
  case 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
      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
      continue $ if upperSemi then VQuant Pi x dom{ typ = VBelow Le VInfty} fv
                 else 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
       (ki, v2, 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
              (av', Kinded ki 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 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
                         v2 <- Expr -> TypeCheck TVal
whnf' Expr
e2e
                         return (ki, v2, e2e)
            else do
              Kinded ki 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
              v2 <- whnf' e2e
              return (ki, v2, e2e)
       bv <- app fv v2
       -- the kind of the application is the kind of its head
       return (Kinded ki $ (x,) $ maybeErase dec e2e, 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
    rho <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Env
forall (m :: * -> *). MonadCxt m => m Env
getEnv
    traceSingM $ "computing singleton <" ++ show e ++ " : " ++ show v2 ++ ">" -- ++ " in environment " ++ show rho
    v2principal <- sing rho e v2
    traceSingM $ "subtype checking " ++ show v2principal ++ " ?<= " ++ show v ++ " in environment " ++ show rho
    subtype v2principal 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
  cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  let parametric = TCContext -> Bool
checkingConType TCContext
cxt  -- are we dealing with a parametric pi?
  let 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 (s1,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
  (tv, 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
  te <- toExpr tv
  return (tv, te, ke)
checkOrInfer Dec
dec Expr
e (Just Expr
t) = do
  Kinded kt te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
  tv <- whnf' te
  Kinded ke ee <- applyDec dec $ checkExpr e tv
  let ki = Kind -> Kind -> Kind
intersectKind Kind
ke (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Kind
predKind Kind
kt
  return $ (tv, te, Kinded ki 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
  (sv, te) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
t
  case 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
  (tv, ee) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr' Expr
e
  case 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
            (v, Kinded ki1 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)
-}
            v <- force v -- if v is a corecursively defined type in Set, unfold!
            tv <- projectType v p =<< whnf' e1e
            return (tv, Kinded ki1 (proj e1e fx 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
        tv' <- Expr -> TVal -> TypeCheck TVal
sing' Expr
ee TVal
tv
        return (tv', Kinded ki 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)
        item <- Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) CxtEntry1
forall (m :: * -> *). MonadCxt m => Name -> m CxtEntry1
lookupName1 Name
x
        traceCheckM ("infer variable: retrieved item ")
        let dom = CxtEntry1 -> Domain
forall a. CxtE a -> a
domain CxtEntry1
item
            av  = Domain -> TVal
forall a. Dom a -> a
typ Domain
dom
        traceCheckM ("infer variable: " ++ show av)
        enterDoc (text "inferExpr: variable" <+> prettyTCM x <+> colon <+> prettyTCM av <+> text "may not occur") $ do
          let dec  = Domain -> Dec
forall a. Dom a -> Dec
decor Domain
dom
              udec = CxtEntry1 -> UDec
forall a. CxtE a -> UDec
upperDec CxtEntry1
item
              pol  = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec
              upol = UDec -> PProd
forall pol. Polarity pol => Decoration pol -> pol
polarity UDec
udec
          when (erased dec && not (erased udec)) $
            recoverFail ", because it is marked as erased"
          enter ", because of polarity" $
            leqPolM pol upol
        traceCheckM ("infer variable returns")
        traceCheckM ("infer variable " ++ show x ++ " : " ++ show av)
        return $ (av, Kinded (kind dom) $ Var 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
        ee <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
        return (VSort (Set (VSucc VZero)), Kinded (kUniv Zero) $ Sort $ CoSet ee)
      Sort (Set Expr
e) ->  do
        (v, ee) <- Expr -> TypeCheck (TVal, Expr)
checkLevel Expr
e
        return (VSort (Set (succSize v)), Kinded (kUniv ee) $ Sort $ Set 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
        ee <- Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Expr
checkSize Expr
e
        return (vTSize, Kinded kTSize $ Below ltle 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)
        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"
-}
        (s1, Kinded ki0 t1e) <- (if pisig==Pi then checkingDom else id) $
          checkingCon False $ inferType t1 -- switch off parametric Pi
        -- the kind of the bound variable is the precedessor of the kind of its type
        let ki1 = Kind -> Kind
predKind Kind
ki0
        addBind (TBind n (Domain t1e ki1 $ defaultDec)) $ 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)
          (s2, Kinded ki2 t2e) <- inferType t2
          ce <- ask
          let er = Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec
          s <- if impredicative ce && er && s2 == Set VZero then return s2 else ptsRule er s1 s2 -- Impredicativity!
          -- improve erasure annotation: irrelevant arguments can be erased!
          let (ki',dec') = if checkCon then
                 -- in case of constructor types the kind is the union
                 -- of the kinds of the constructor arguments
                 if ki0 == kTSize then (ki2, irrelevantDec)
                  else if erased dec then (ki2, dec) -- do not count erased args in
                 else (unionKind ki0 ki2, dec)
                else (ki2, if argKind ki0 `irrelevantFor` (predKind ki2)
                            then irrelevantDec
                            else dec)
          -- the kind of the Pi-type is the kind of its target (codomain)
          return (VSort s, Kinded ki' $ Quant pisig (TBind n (Domain t1e ki1 dec')) t2e)

      Quant PiSigma
Pi (TMeasure (Measure [Expr]
mu)) Expr
t2 -> do
        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
        (s, Kinded ki2 t2e) <- inferType t2
        return (VSort s, Kinded ki2 $ Quant Pi (TMeasure (Measure mue)) t2e)

      Quant PiSigma
Pi (TBound (Bound LtLe
ltle (Measure [Expr]
mu) (Measure [Expr]
mu'))) Expr
t2 -> do
        (mue,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
          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
          mue' <- mapM checkSize mu'
          return (mue,mue')
        (s, Kinded ki2 t2e) <- inferType t2
        return (VSort s, Kinded ki2 $ Quant Pi (TBound (Bound ltle (Measure mue) (Measure mue'))) t2e)

      Sing Expr
e1 Expr
t -> do
        (s, Kinded ki te) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t
        tv <- whnf' te
        Kinded ki1 e1e <- checkExpr e1 tv
        return (VSort $ s, Kinded (intersectKind ki $ succKind ki1) -- not sure how useful the intersection is, maybe just ki is good enough
                             $ Sing e1e 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
        (v, Kinded ki1 e1e) <- Expr -> TypeCheck (TVal, Kinded Expr)
inferExpr Expr
e1
        (Kinded ki2 (_, e2e), bv) <- checkApp e2 v
        -- the kind of the application is the kind of its head
        return (bv, Kinded ki1 $ App e1e 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)
         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 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)
             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 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
             return (typ $ domain item, Kinded (kind $ domain item) $ e)
           Maybe CxtEntry1
Nothing -> -- otherwise, it is not the data type name just being defined
                 do sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
name
                    case 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
      (s, te) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t
      leqSort Pos s (Set VInfty)
      return 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
      (s, te) <- Expr
-> StateT
     TCState
     (ReaderT TCContext (ExceptT TraceError IO))
     (Sort TVal, Kinded Expr)
inferType Expr
t
      case 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]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Telescope, a)
loop [TBind]
tel where
  loop :: [TBind]
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (Telescope, a)
loop [TBind]
tel = case [TBind]
tel of
    []                                  -> (Telescope
emptyTel,) (a -> (Telescope, a))
-> TypeCheck a
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) (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 ki te <- Expr -> TypeCheck (Kinded Expr)
checkType Expr
t
      let 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)
      (tel, a) <- addBind tb $ loop tel
      return (Telescope $ tb : telescope tel, 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 k1 ce  <- Int -> TVal -> TVal -> Clause -> TypeCheck (Kinded Clause)
checkCase Int
i TVal
v TVal
tv Clause
c
    Kinded k2 cle <- checkCases' (i + 1) v tv cl
    return $ Kinded (unionKind k1 k2) $ ce : 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
      (flex,ins,cxt,vt,pe,pv,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
      local (\ TCContext
_ -> TCContext
cxt) $ do
        mapM_ (checkGoal ins) flex
        tel <- getContextTele -- TODO!
        case (absp,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 ki rhse <- Substitution -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkRHS Substitution
ins Expr
rhs TVal
vt'
                return $ Kinded ki (Clause tel [pe] (Just 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
  tv <- Expr -> TypeCheck TVal
whnf' Expr
t
  checkClauses tv 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 ki1 ce  <- Int -> TVal -> Clause -> TypeCheck (Kinded Clause)
checkClause Int
i TVal
tv Clause
c
    Kinded ki2 cle <- checkClauses' (i + 1) tv cl
    return $ Kinded (unionKind ki1 ki2) $ (ce : 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
    (flex,ins,cxt,tv0,ple,plv,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.
    local (\ TCContext
_ -> TCContext
cxt { consistencyCheck = (mutualCo cxt == Ind) }) $ do
      mapM_ (checkGoal ins) 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
      tel <- getContextTele -- WRONG TELE, has VGens for DotPs
      case (absp,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 ki rhse <- Substitution -> Expr -> TVal -> TypeCheck (Kinded Expr)
checkRHS Substitution
ins Expr
rhs TVal
tv0
            env  <- getEnv
            [rhse] <- solveAndModify [rhse] env
            return $ Kinded ki (Clause tel ple (Just 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 cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
               return (flex,ins,cxt,v,[],[],False)
      (Pattern
p:[Pattern]
pl') -> do (flex',ins',cxt',v',pe,pv,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
                    local (\ TCContext
_ -> TCContext
cxt') $ do
                      (flex'',ins'',cxt'',v'',ple,plv,absps) <- checkPatterns dec0 flex' ins' v' pl'
                      return (flex'',ins'',cxt'',v'', pe:ple, pv:plv, absp || 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
  tv <- TVal -> TypeCheck TVal
force TVal
tv
  case tv of
    -- record type can be eliminated
    VApp (VDef (DefId IdKind
DatK QName
d)) [TVal]
vl ->
      case Pattern
p of
        ProjP Name
proj -> do
          tv <- TVal -> Name -> TVal -> TypeCheck TVal
projectType TVal
tv Name
proj TVal
VIrr -- do not have record value here
          cxt <- ask
          return (flex, ins, cxt, tv, p, VProj Post proj, 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
        tv <- TVal
fv TVal -> TVal -> TypeCheck TVal
`app` TVal
xv
        checkPattern dec0 (DotFlex i Nothing dom : flex) ins tv 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 <- (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
                 when (co /= CoInd) $
                   throwErrorMsg ("successor pattern only allowed in cofun")

                 enterDoc (text ("checkPattern " ++ show p ++" : matching on size, checking that target") <+> prettyTCM tv <+> text "ends in correct coinductive sized type") $
                   underAbs x domEr fv $ \ Int
i TVal
_ TVal
bv -> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
endsInSizedCo Int
i TVal
bv

                 cxt <- ask
                 -- 2012-02-05 assume size variable in SuccP to be < #
                 let sucTy = (TVal
vFinSize TVal -> TVal -> TVal
`arrow` TVal
vFinSize)
                 (flex',ins',cxt',tv',p2e,p2v,absp) <- checkPattern decEr flex ins sucTy p2
                 -- leqVal Mixed delta' VSet VSize av -- av = VSize
                 let pe = Pattern -> Pattern
forall e. Pat e -> Pat e
SuccP Pattern
p2e
                 let 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??
                 vb  <- app fv 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"
-}
                 return (flex',ins',cxt',vb,pe,pv,absp)

         -- other patterns: no need to know about result type
         Pattern
_ -> do
           (flex',ins',cxt',pe,pv,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))
           vb  <- app fv pv
           vb  <- substitute ins' vb  -- from ConP case -- ?? why not first subst and then whnf?
           -- traceCheckM ("Returning type " ++ show vb)
           return (flex',ins',cxt',vb,pe,pv,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
       p <- TVal
-> Pattern
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) Pattern
turnIntoVarPatAtUnitType TVal
av Pattern
p
       case 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
            av <- TVal -> TypeCheck TVal
force TVal
av
            case av of
             VQuant PiSigma
Sigma Name
y dom1 :: Domain
dom1@(Domain TVal
av1 Kind
ki1 Dec
dec1) TVal
fv -> do
              (flex, ins, cxt, pe1, pv1, 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
              av2 <- app fv pv1
              (flex, ins, cxt, pe2, pv2, absp2) <-
                 local (const cxt) $
                   checkPattern' flex ins (Domain av2 ki decEr) p2
              return (flex, ins, cxt, PairP pe1 pe2, VPair pv1 pv2, absp1 || 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
              cxt' <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
              p' <- case 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
              return (flex, ins, cxt', maybeErase $ p', xv, 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
            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)
            newWithGen y domEr $ \ Int
j TVal
xv -> do
{-
               VGen k <- whnf' (Var z)
               addSizeRel j 1 k $ do  -- j < k
-}
               ve <- Expr -> TypeCheck TVal
whnf' Expr
e
               addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $ do
                 subtype av (VBelow Lt ve)
                 cxt' <- ask
                 return (flex, ins, cxt', maybeErase $ SizeP e y, xv, 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)
                 cxt' <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
                 return (MaxMatches 0 av : flex, ins, cxt', maybeErase $ AbsurdP, VIrr, 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
                 n <- QName -> TVal -> TypeCheck QName
disambigCon QName
n TVal
av

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

                 -- First check that we do not match against an irrelevant argument.
                 unless dotted $ nonDottedConstructorChecks n co pl
{- TODO
                 enter ("can only match non parametric arguments") $
                   leqPolM (polarity dec) (pprod defaultPol)
-}
                 (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <- checkConstructorPattern co n pl

                 when (isFunType vc') $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " of type " ++ show vc' ++ " not allowed")
                 let 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 = 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
                 dot <- if dottedPat pi then mkDotted True else return notDotted
                 pv0 <- mkConVal dot co n pvs 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
-}

                 subst <- local (\ TCContext
_ -> TCContext
cxt') $ do
                   case av of  -- TODO: need subtyping-unify instead of unify??
                     VSing TVal
vav TVal
av0 -> do
                       vav <- TVal -> TypeCheck TVal
whnfClos TVal
vav
                       inst Pos flexgen av0 pv0 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'
-}
                 ins''   <- compSubst ins' subst -- 2010-07-27 not ok to switch!
                 delta'' <- substitute ins'' (context cxt')
                 traceCheckM $ "delta'' = " ++ show delta''
                 av  <- substitute ins'' av  -- 2010-09-22: update av
                 pv  <- up False pv0 av

                 -- if the constructor was dotted, make sure it is the only match
                 let 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'
                 return (flex'', ins'', cxt' { context = delta'' },
                         maybeErase pe, pv, 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
                       cxt' <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
                       -- traceCheck ("Returning type " ++ show vb) $
                       return (DotFlex k (Just e) domEr : flex
                              ,ins
                              ,cxt'
                              ,maybeErase $ DotP e -- $ Var xp -- DotP $ Meta k -- e -- Meta k
                              -- ,maybeErase $ -- AbsurdP -- VarP $ show e
                              ,xv
                              ,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 {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, 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
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 (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 = 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
                 vc <- instConLType n conPars vc isSz isFlex dataPars =<< force 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) <-
                 (vc,) <$> checkPatterns decEr flex ins vc 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 {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, 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
        when (co == CoCons && isJust sz) $ do
          let sizep = [Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
head [Pattern]
pl  -- 2012-01-22: WAS (pl !! nPars)
          unless (isDotPattern sizep) $
            throwErrorMsg $ "in pattern " ++ show p  ++ ", coinductive size sub pattern " ++ show sizep ++ " must be dotted"

        when (not $ decEr `elem` map Dec [Const,Rec]) $
          recoverFail $ "cannot match pattern " ++ show p ++ " against non-computational argument"
        -- check not to match non-trivially against erased stuff
        when (decEr == Dec Const) $ do
          let 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"
          mcenvs <- matchingConstructors av
          case mcenvs of
             Maybe [(ConstructorInfo, Env)]
Nothing -> do -- now check whether dataName is a record type
               DataSig { constructors } <- Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => Name -> m SigDef
lookupSymb Name
dataName
               unless (length constructors == 1) $ failNotForced
               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
      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)
      ask >>= \ 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
      resurrect $ do -- consider a DotP e always as irrelevant!
        e <- valueOf <$> checkExpr e tv
        v' <-  whnf' e -- TODO: has subst erased terms?
        enterDoc (text "inferred value" <+> prettyTCM v <+> text "does not match given dot pattern value" <+> prettyTCM v') $
          leqVal Pos tv v 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)
  av' <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute Substitution
subst TVal
av
  traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av')
  -- av' <- reval av'
  -- traceCheckM ("checkGoal: reevalutated " ++ show av')
  mcenvs <- matchingConstructors av'
  traceCheckM ("checkGoal matching constructors = " ++ show mcenvs)
  maybe (recoverFail $ "not a data type: " ++ show 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 ())
   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
     cxt <- StateT
  TCState (ReaderT TCContext (ExceptT TraceError IO)) TCContext
forall r (m :: * -> *). MonadReader r m => m r
ask
     let rho = TCContext -> Env2
environ TCContext
cxt
     mmu' <- Traversable.mapM (substitute ins) (envBound rho)
     local (\ TCContext
_ -> TCContext
cxt { environ = rho { envBound = mmu' }}) $
       activateFuns $
         checkExpr rhs 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 = np, symbTyp = tv, positivity = posl}) <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
d1
      instList posl flex tv vl1 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
  v1 <- TVal -> TypeCheck TVal
whnfClos TVal
w1
  v2 <- whnfClos w2
  inst pos flex tv v1 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 { numPars, symbTyp = tv, positivity = posl }) <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
d1
         instList' numPars posl flex tv vl1 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
         sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
c1
         instList [] flex (symbTyp sige) (map snd rs1) (map snd 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
      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
      u1 <- substitute subst v1'
      u2 <- substitute subst v2'
      tv1' <- substitute subst tv1
      inst pos flex tv1' u1 u2 >>= compSubst 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
  v1 <- TVal -> TypeCheck TVal
whnfClos TVal
v1
  v2 <- whnfClos v2
  if (np <= 0 || isMeta flex v1 || isMeta flex v2) then
    case 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)
        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
        vl1' <- mapM (substitute subst) vl1
        vl2' <- mapM (substitute subst) vl2
        v    <- substitute subst v1
        fv   <- substitute subst fv
        vb   <- app fv v
        subst' <- instList' (np - 1) (tailPosl posl) flex vb vl1' vl2'
        compSubst subst subst'
   else
    case tv of
      (VQuant PiSigma
Pi Name
x Domain
dom TVal
fv) -> do
        vb   <- TVal -> TVal -> TypeCheck TVal
app TVal
fv TVal
v2
        instList' (np - 1) (tailPosl posl) flex vb vl1 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
    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)
    return $ 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
               v0 <- TVal -> TypeCheck TVal
whnfClos ([TVal]
vl [TVal] -> Int -> TVal
forall a. HasCallStack => [a] -> Int -> a
!! Int
p)
               case 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
        v0 <- TVal -> TypeCheck TVal
whnfClos TVal
v0
        case 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
  (cls, inco) <- [Clause] -> TVal -> TypeCheck ([Clause], [Co])
admClauses [Clause]
cls TVal
tv
  when (co==CoInd && not (co `elem` inco)) $
    throwErrorMsg $ show tv ++ " is not a type of a cofun" -- ++ if co==Ind then "fun" else "cofun"
  return 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
  (cl',inco) <- Clause -> TVal -> TypeCheck (Clause, [Co])
admClause Clause
cl TVal
tv
  (cls',inco') <- admClauses cls tv
  return (cl' : cls', inco ++ 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
       (ps', inco) <- [(Pattern, TVal)] -> TVal -> TypeCheck ([Pattern], [Co])
admPatterns [(Pattern, TVal)]
pvs TVal
tv
       return (Clause tel ps' e, inco)

admPatterns :: [(Pattern,Val)] -> TVal -> TypeCheck ([Pattern], [Co])
admPatterns :: [(Pattern, TVal)] -> TVal -> TypeCheck ([Pattern], [Co])
admPatterns [] TVal
tv = do
  isCo <- TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
endsInCo TVal
tv
  return ([], if isCo then [CoInd] else [])
admPatterns ((Pattern
p,TVal
v):[(Pattern, TVal)]
pvs) TVal
tv = do
   (p, inco1)  <- Pattern -> TVal -> TypeCheck (Pattern, [Co])
admPattern Pattern
p TVal
tv
   bv <- piApp tv v
   (ps, inco2) <- admPatterns pvs bv
   return (p:ps, inco1 ++ 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
  av <- TVal -> TypeCheck TVal
force TVal
av
  let 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 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
      sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
      case 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)
          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 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
          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 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
            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
            Foldable.forM_ match $ \ 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
   tv <- TVal -> TypeCheck TVal
force TVal
tv
   let 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 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
         sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
         case 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
                 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 isVGeni v then return () else 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)
  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 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
      tv <- Env -> Expr -> TypeCheck TVal
whnf Env
rho (FieldInfo -> Expr
fType FieldInfo
f)
      -- do not need to check erased fields?
      when (not $ erased (fDec f)) $ check tv
      -- for non-index fields, value is not given by matching, so introduce
      -- generic value
      new (fName f) (Domain tv defaultKind (fDec f)) $ \ 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
         sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
         case 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
           inco <- Int -> TVal -> TypeCheck [Co]
admType Int
k TVal
bv
           when (CoInd `elem` inco && not (shallowSuccP p)) $ cannotMatchDeep p tv
           if (CoInd `elem` inco)
              || (inco /= [] && completeP p)
            then return (p, inco)
            else return (UnusableP p, 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
          isInd <- Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
szUsed Co
Ind Int
i TVal
av
          when (not isInd) $
            szAntitone i av `newErrorDoc` docNotLowerSemi i av
          underAbs x dom fv $ \ Int
gen TVal
_ TVal
bv -> do
            inco <- Int -> TVal -> TypeCheck [Co]
admType Int
i TVal
bv
            if isInd then return (Ind : inco) else return inco
       TVal
_ -> do
          isCoind <- Co
-> Int
-> TVal
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
szUsed Co
CoInd  Int
i TVal
tv
          if isCoind then return [CoInd]
           else do
            szMonotone i tv
            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)
                sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
                case 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 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 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
  l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
  admEndsInCo tv 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
         l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
         let 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)
         underAbs x dom fv $ \ 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
         sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
         case 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
               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 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)
   tv' <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute (Int -> TVal -> Substitution
sgSub Int
i TVal
si) TVal
tv
   leqVal Pos vTopSort tv 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)
   tv' <- Substitution -> TVal -> TypeCheck TVal
forall a. Substitute a => Substitution -> a -> TypeCheck a
substitute (Int -> TVal -> Substitution
sgSub Int
i TVal
si) TVal
tv
   leqVal Neg vTopSort tv 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 sige <- QName
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
                case 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 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 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"