{-# LANGUAGE TupleSections, FlexibleInstances, FlexibleContexts, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Eval where
import Prelude hiding (mapM, null, pi)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad hiding (mapM)
import Control.Monad.State (StateT, execStateT, get, gets, put)
import Control.Monad.Except (runExcept, MonadError)
import Control.Monad.Reader (asks, local)
import qualified Data.Array as Array
import qualified Data.List as List
import qualified Data.Map as Map
#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (foldMap)
import Data.Monoid
import Data.Traversable (traverse)
#endif
import Data.Traversable (mapM)
import Abstract
import Polarity as Pol
import Value
import TCM
import PrettyTCM hiding ((<>))
import qualified PrettyTCM as P
import Warshall
import TraceError
import Util
traceEta, traceRecord, traceMatch, traceLoop, traceSize :: String -> a -> a
traceEtaM, traceRecordM, traceMatchM, traceLoopM, traceSizeM :: Monad m => String -> m ()
traceEta :: forall a. String -> a -> a
traceEta String
msg a
a = a
a
traceEtaM :: forall (m :: * -> *). Monad m => String -> m ()
traceEtaM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceRecord :: forall a. String -> a -> a
traceRecord String
msg a
a = a
a
traceRecordM :: forall (m :: * -> *). Monad m => String -> m ()
traceRecordM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceMatch :: forall a. String -> a -> a
traceMatch String
msg a
a = a
a
traceMatchM :: forall (m :: * -> *). Monad m => String -> m ()
traceMatchM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceLoop :: forall a. String -> a -> a
traceLoop String
msg a
a = a
a
traceLoopM :: forall (m :: * -> *). Monad m => String -> m ()
traceLoopM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceSize :: forall a. String -> a -> a
traceSize String
msg a
a = a
a
traceSizeM :: forall (m :: * -> *). Monad m => String -> m ()
traceSizeM String
msg = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
failValInv :: (MonadError TraceError m) => Val -> m a
failValInv :: forall (m :: * -> *) a. MonadError TraceError m => Val -> m a
failValInv Val
v = 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
"internal error: value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" violates representation invariant"
class Reval a where
reval' :: Valuation -> a -> TypeCheck a
reval :: a -> TypeCheck a
reval = Valuation -> a -> TypeCheck a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
emptyVal
instance Reval a => Reval (Maybe a) where
reval' :: Valuation -> Maybe a -> TypeCheck (Maybe a)
reval' Valuation
valu Maybe a
ma = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Maybe a -> TypeCheck (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Valuation
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu) Maybe a
ma
instance Reval b => Reval (a,b) where
reval' :: Valuation -> (a, b) -> TypeCheck (a, b)
reval' Valuation
valu (a
x,b
v) = (a
x,) (b -> (a, b))
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
-> TypeCheck (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Valuation
-> b
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu b
v
instance Reval a => Reval [a] where
reval' :: Valuation -> [a] -> TypeCheck [a]
reval' Valuation
valu [a]
vs = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> [a] -> TypeCheck [a]
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 (Valuation
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu) [a]
vs
instance Reval Env where
reval' :: Valuation -> Env -> TypeCheck Env
reval' Valuation
valu (Environ [(Name, Val)]
rho Maybe (Measure Val)
mmeas) =
([(Name, Val)] -> Maybe (Measure Val) -> Env)
-> Maybe (Measure Val) -> [(Name, Val)] -> Env
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Name, Val)] -> Maybe (Measure Val) -> Env
forall a. [(Name, a)] -> Maybe (Measure Val) -> Environ a
Environ Maybe (Measure Val)
mmeas ([(Name, Val)] -> Env)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
-> TypeCheck Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Valuation
-> [(Name, Val)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu [(Name, Val)]
rho
instance Reval Valuation where
reval' :: Valuation -> Valuation -> TypeCheck Valuation
reval' Valuation
valu (Valuation [(Int, Val)]
valu') = [(Int, Val)] -> Valuation
Valuation ([(Int, Val)] -> Valuation)
-> ([(Int, Val)] -> [(Int, Val)]) -> [(Int, Val)] -> Valuation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Int, Val)] -> [(Int, Val)] -> [(Int, Val)]
forall a. [a] -> [a] -> [a]
++ Valuation -> [(Int, Val)]
valuation Valuation
valu) ([(Int, Val)] -> Valuation)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Int, Val)]
-> TypeCheck Valuation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Valuation
-> [(Int, Val)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Int, Val)]
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu [(Int, Val)]
valu'
instance Reval a => Reval (Measure a) where
reval' :: Valuation -> Measure a -> TypeCheck (Measure a)
reval' Valuation
valu Measure a
beta = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Measure a -> TypeCheck (Measure a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Measure a -> f (Measure b)
traverse (Valuation
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu) Measure a
beta
instance Reval a => Reval (Bound a) where
reval' :: Valuation -> Bound a -> TypeCheck (Bound a)
reval' Valuation
valu Bound a
beta = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Bound a -> TypeCheck (Bound a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
traverse (Valuation
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu) Bound a
beta
instance Reval Val where
reval' :: Valuation -> Val -> TypeCheck Val
reval' Valuation
valu Val
u = String -> TypeCheck Val -> TypeCheck Val
forall a. String -> a -> a
traceLoop (String
"reval " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
u) (TypeCheck Val -> TypeCheck Val) -> TypeCheck Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ do
let reval :: a -> TypeCheck a
reval a
v = Valuation -> a -> TypeCheck a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu a
v
reEnv :: a -> TypeCheck a
reEnv a
rho = Valuation -> a -> TypeCheck a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu a
rho
reFun :: a -> TypeCheck a
reFun a
fv = Valuation -> a -> TypeCheck a
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu a
fv
case Val
u of
VSort (CoSet Val
v) -> Sort Val -> Val
VSort (Sort Val -> Val) -> (Val -> Sort Val) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Sort Val
forall a. a -> Sort a
CoSet (Val -> Val) -> TypeCheck Val -> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v
VSort{} -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
Val
VInfty -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
Val
VZero -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
VSucc{} -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
VMax{} -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
VPlus{} -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
VProj{} -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
VPair Val
v1 Val
v2 -> Val -> Val -> Val
VPair (Val -> Val -> Val)
-> TypeCheck Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v1 StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
-> TypeCheck Val -> TypeCheck Val
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
<*> Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v2
VRecord RecInfo
ri [(Name, Val)]
rho -> RecInfo -> [(Name, Val)] -> Val
VRecord RecInfo
ri ([(Name, Val)] -> Val)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
-> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Val)
-> [(Name, Val)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
forall (m :: * -> *) a b n.
(Applicative m, Monad m) =>
(a -> m b) -> [(n, a)] -> m [(n, b)]
mapAssocM Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval [(Name, Val)]
rho
VApp Val
v [Val]
vl -> do
v' <- Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v
vl' <- mapM reval vl
w <- foldM app v' vl'
reduce w
VDef{} -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> [Val] -> Val
VApp Val
u []
VGen Int
i -> Val -> TypeCheck Val
reduce (Int -> Valuation -> Val
valuateGen Int
i Valuation
valu)
VCase Val
v Val
tv Env
env [Clause]
cl -> do
v' <- Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v
tv' <- reval tv
env' <- reEnv env
evalCase v' tv' env' cl
VBelow LtLe
ltle Val
v -> LtLe -> Val -> Val
VBelow LtLe
ltle (Val -> Val) -> TypeCheck Val -> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v
VGuard Bound Val
beta Val
v -> Bound Val -> Val -> Val
VGuard (Bound Val -> Val -> Val)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound Val)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bound Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound Val)
forall {a}. Reval a => a -> TypeCheck a
reval Bound Val
beta StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
-> TypeCheck Val -> TypeCheck Val
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
<*> Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v
VQuant PiSigma
pisig Name
x Domain
dom Val
fv ->
PiSigma -> Name -> Domain -> Val -> Val
VQuant PiSigma
pisig Name
x
(Domain -> Val -> Val)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Domain
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Val)
-> Domain
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Domain
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)
mapM Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Domain
dom
StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
-> TypeCheck Val -> TypeCheck Val
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
<*> Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reFun Val
fv
VConst Val
v -> Val -> Val
VConst (Val -> Val) -> TypeCheck Val -> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Valuation -> Val -> TypeCheck Val
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu Val
v
VLam Name
x Env
env Expr
e -> (Env -> Expr -> Val) -> Expr -> Env -> Val
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> Env -> Expr -> Val
VLam Name
x) Expr
e (Env -> Val) -> TypeCheck Env -> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Valuation -> Env -> TypeCheck Env
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu Env
env
VAbs Name
x Int
i Val
v Valuation
valu' -> Name -> Int -> Val -> Valuation -> Val
VAbs Name
x Int
i Val
v (Valuation -> Val) -> TypeCheck Valuation -> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Valuation -> Valuation -> TypeCheck Valuation
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu Valuation
valu'
VUp Val
v Val
tv -> Bool -> Val -> Val -> TypeCheck Val
up Bool
False (Val -> Val -> TypeCheck Val)
-> (TypeCheck Val, TypeCheck Val) -> TypeCheck Val
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (Valuation -> Val -> TypeCheck Val
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu Val
v, Valuation -> Val -> TypeCheck Val
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Valuation
valu Val
tv)
VClos Env
env Expr
e -> do env' <- Env -> TypeCheck Env
forall {a}. Reval a => a -> TypeCheck a
reEnv Env
env
return $ VClos env' e
VMeta Int
i Env
env Int
k -> do env' <- Env -> TypeCheck Env
forall {a}. Reval a => a -> TypeCheck a
reEnv Env
env
return $ VMeta i env' k
VSing Val
v Val
tv -> Val -> Val -> TypeCheck Val
vSing (Val -> Val -> TypeCheck Val)
-> (TypeCheck Val, TypeCheck Val) -> TypeCheck Val
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
v, Val -> TypeCheck Val
forall {a}. Reval a => a -> TypeCheck a
reval Val
tv)
Val
VIrr -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
u
Val
v -> String -> TypeCheck Val
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck Val) -> String -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ String
"NYI : reval " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v
vSing :: Val -> TVal -> TypeCheck TVal
vSing :: Val -> Val -> TypeCheck Val
vSing Val
v (VQuant PiSigma
Pi Name
x' Domain
dom Val
fv) = do
let x :: Name
x = String -> Name
fresh (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ if Name -> Bool
emptyName Name
x' then String
"xSing#" else Name -> String
suggestion Name
x'
PiSigma -> Name -> Domain -> Val -> Val
VQuant PiSigma
Pi Name
x Domain
dom (Val -> Val) -> TypeCheck Val -> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Name
-> Domain
-> Val
-> (Int -> Val -> Val -> TypeCheck Val)
-> TypeCheck Val
forall a.
Name
-> Domain
-> Val
-> (Int -> Val -> Val -> TypeCheck a)
-> TypeCheck a
underAbs_ Name
x Domain
dom Val
fv ((Int -> Val -> Val -> TypeCheck Val) -> TypeCheck Val)
-> (Int -> Val -> Val -> TypeCheck Val) -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ \ Int
i Val
xv Val
bv -> do
v <- Val -> Val -> TypeCheck Val
app Val
v Val
xv
vAbs x i <$> vSing v bv
vSing Val
_ tv :: Val
tv@(VSing{}) = Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val
tv
vSing Val
v Val
tv = Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Val
VSing Val
v Val
tv
reduce :: Val -> TypeCheck Val
reduce :: Val -> TypeCheck Val
reduce Val
v = String -> TypeCheck Val -> TypeCheck Val
forall a. String -> a -> a
traceLoop (String
"reduce " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v) (TypeCheck Val -> TypeCheck Val) -> TypeCheck Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$
do
rewrules <- (TCContext -> Rewrites)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Rewrites
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> Rewrites
rewrites
mr <- findM (\ Rewrite
rr -> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
v (Rewrite -> Val
lhs Rewrite
rr)) rewrules
case mr of
Maybe Rewrite
Nothing -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v
Just Rewrite
rr -> String -> TypeCheck Val -> TypeCheck Val
forall a. String -> a -> a
traceRew (String
"firing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rewrite -> String
forall a. Show a => a -> String
show Rewrite
rr) (TypeCheck Val -> TypeCheck Val) -> TypeCheck Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rewrite -> Val
rhs Rewrite
rr)
equal :: Val -> Val -> TypeCheck Bool
equal :: Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
u1 Val
u2 = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. String -> a -> a
traceLoop (String
"equal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
u1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =?= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
u2) (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 (Val
u1,Val
u2) of
(Val
v1,Val
v2) | Val
v1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
v2 -> 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
(VApp Val
v1 [Val]
vl1, VApp Val
v2 [Val]
vl2) ->
(Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
v1 Val
v2) 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 (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`andLazy` ([Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equals' [Val]
vl1 [Val]
vl2)
(VQuant PiSigma
pisig1 Name
x1 Domain
dom1 Val
fv1, VQuant PiSigma
pisig2 Name
x2 Domain
dom2 Val
fv2) | PiSigma
pisig1 PiSigma -> PiSigma -> Bool
forall a. Eq a => a -> a -> Bool
== PiSigma
pisig2 ->
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 (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
andLazy (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal (Domain -> Val
forall a. Dom a -> a
typ Domain
dom1) (Domain -> Val
forall a. Dom a -> a
typ Domain
dom2)) (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
$
Name
-> Domain
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Name
-> Domain
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (Val -> m a) -> m a
new Name
x1 Domain
dom1 ((Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Val
vx -> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (TypeCheck Val, TypeCheck Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (Val -> Val -> TypeCheck Val
app Val
fv1 Val
vx, Val -> Val -> TypeCheck Val
app Val
fv2 Val
vx)
(VProj PrePost
_ Name
p, VProj PrePost
_ Name
q) -> 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
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ Name
p Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
q
(VPair Val
v1 Val
w1, VPair Val
v2 Val
w2) -> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
v1 Val
v2) 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 (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`andLazy` (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
w1 Val
w2)
(VBelow LtLe
ltle1 Val
v1, VBelow LtLe
ltle2 Val
v2) | LtLe
ltle1 LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
ltle2 -> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
v1 Val
v2
(VSing Val
v1 Val
tv1, VSing Val
v2 Val
tv2) -> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
v1 Val
v2) 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 (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`andLazy` (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
tv1 Val
tv2)
(Val
fv1, Val
fv2) | Val -> Bool
isFun Val
fv1, Val -> Bool
isFun Val
fv2 ->
Name
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Name
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Name -> (Val -> m a) -> m a
addName ([Name] -> Name
bestName [Val -> Name
absName Val
fv1, Val -> Name
absName Val
fv2]) ((Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Val
vx ->
Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (TypeCheck Val, TypeCheck Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (Val -> Val -> TypeCheck Val
app Val
fv1 Val
vx, Val -> Val -> TypeCheck Val
app Val
fv2 Val
vx)
(VRecord RecInfo
ri1 [(Name, Val)]
rho1, VRecord RecInfo
ri2 [(Name, Val)]
rho2) | RecInfo -> RecInfo -> Bool
notDifferentNames RecInfo
ri1 RecInfo
ri2 -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Bool]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
((Name, Val)
-> (Name, Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [(Name, Val)]
-> [(Name, Val)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ (Name
n1,Val
v1) (Name
n2,Val
v2) -> ((Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n2) Bool -> Bool -> Bool
&&) (Bool -> Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal' Val
v1 Val
v2) [(Name, Val)]
rho1 [(Name, Val)]
rho2
(Val, Val)
_ -> 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
notDifferentNames :: RecInfo -> RecInfo -> Bool
notDifferentNames :: RecInfo -> RecInfo -> Bool
notDifferentNames (NamedRec ConK
_ QName
n Bool
_ Dotted
_) (NamedRec ConK
_ QName
n' Bool
_ Dotted
_) = QName
n QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
n'
notDifferentNames RecInfo
_ RecInfo
_ = Bool
True
equals' :: [Val] -> [Val] -> TypeCheck Bool
equals' :: [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equals' [] [] = 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
equals' (Val
w1:[Val]
vs1) (Val
w2:[Val]
vs2) = (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal' Val
w1 Val
w2) 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 (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`andLazy` ([Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equals' [Val]
vs1 [Val]
vs2)
equals' [Val]
vl1 [Val]
vl2 = 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
equal' :: Val -> Val -> TypeCheck Bool
equal' :: Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal' Val
w1 Val
w2 = Val -> TypeCheck Val
whnfClos Val
w1 TypeCheck Val
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> (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
>>= \ Val
v1 -> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
equal Val
v1 (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> TypeCheck Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> TypeCheck Val
whnfClos Val
w2
reify :: Val -> TypeCheck Expr
reify :: Val -> TypeCheck Expr
reify Val
v = (Int, Bool) -> Val -> TypeCheck Expr
reify' (Int
5, Bool
True) Val
v
reify' :: (Int, Bool) -> Val -> TypeCheck Expr
reify' :: (Int, Bool) -> Val -> TypeCheck Expr
reify' (Int, Bool)
m Val
v0 = do
let reify :: Val -> TypeCheck Expr
reify = (Int, Bool) -> Val -> TypeCheck Expr
reify' (Int, Bool)
m
case Val
v0 of
(VClos Env
rho Expr
e) -> Env -> Expr -> TypeCheck Val
whnf Env
rho Expr
e TypeCheck Val -> (Val -> TypeCheck Expr) -> TypeCheck 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
>>= Val -> TypeCheck Expr
reify
(Val
VZero) -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Expr
Zero
(Val
VInfty) -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Expr
Infty
(VSucc Val
v) -> Expr -> Expr
Succ (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
reify Val
v
(VMax [Val]
vs) -> [Expr] -> Expr
maxE ([Expr] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> [Val]
-> 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 Val -> TypeCheck Expr
reify [Val]
vs
(VPlus [Val]
vs) -> [Expr] -> Expr
Plus ([Expr] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> [Val]
-> 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 Val -> TypeCheck Expr
reify [Val]
vs
(VMeta Int
x Env
rho Int
n) ->
Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> Expr -> [Expr]
forall a. (a -> a) -> a -> [a]
iterate Expr -> Expr
Succ (Int -> Expr
Meta Int
x) [Expr] -> Int -> Expr
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
(VSort (CoSet Val
v)) -> Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> (Expr -> Sort Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Sort Expr
forall a. a -> Sort a
CoSet (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
reify Val
v
(VSort Sort Val
s) -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Sort Val -> Sort Expr
vSortToSort Sort Val
s
(VBelow LtLe
ltle Val
v) -> LtLe -> Expr -> Expr
Below LtLe
ltle (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
reify Val
v
(VQuant PiSigma
pisig Name
x Domain
dom Val
fv) -> do
dom' <- (Val -> TypeCheck Expr)
-> Domain
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Dom 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) -> Dom a -> m (Dom b)
mapM Val -> TypeCheck Expr
reify Domain
dom
underAbs_ x dom fv $ \ Int
k Val
xv Val
vb -> do
let x' :: Name
x' = String -> Name
unsafeName (Name -> String
suggestion Name
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k)
PiSigma -> TBind -> Expr -> Expr
piSig PiSigma
pisig (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
x' Dom Expr
dom') (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
reify Val
vb
(VSing Val
v Val
tv) -> (Expr -> Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr -> TypeCheck Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Expr -> Expr -> Expr
Sing (Val -> TypeCheck Expr
reify Val
v) (Val -> TypeCheck Expr
reify Val
tv)
Val
fv | Val -> Bool
isFun Val
fv -> do
let x :: Name
x = Val -> Name
absName Val
fv
Name -> (Val -> TypeCheck Expr) -> TypeCheck Expr
forall a.
Name
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Name -> (Val -> m a) -> m a
addName Name
x ((Val -> TypeCheck Expr) -> TypeCheck Expr)
-> (Val -> TypeCheck Expr) -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ \ xv :: Val
xv@(VGen Int
k) -> do
vb <- Val -> Val -> TypeCheck Val
app Val
fv Val
xv
let x' = String -> Name
unsafeName (Name -> String
suggestion Name
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k)
Lam defaultDec x' <$> reify vb
(VUp Val
v Val
tv) -> Val -> TypeCheck Expr
reify Val
v
(VGen Int
k) -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Name -> Expr
Var (Name -> Expr) -> Name -> Expr
forall a b. (a -> b) -> a -> b
$ String -> Name
unsafeName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"~" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k
(VDef DefId
d) -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ DefId -> Expr
Def DefId
d
(VProj PrePost
fx Name
n) -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ PrePost -> Name -> Expr
Proj PrePost
fx Name
n
(VPair Val
v1 Val
v2) -> Expr -> Expr -> Expr
Pair (Expr -> Expr -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
reify Val
v1 StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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
<*> Val -> TypeCheck Expr
reify Val
v2
(VRecord RecInfo
ri [(Name, Val)]
rho) -> RecInfo -> [(Name, Expr)] -> Expr
Record RecInfo
ri ([(Name, Expr)] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Expr)]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> [(Name, Val)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Expr)]
forall (m :: * -> *) a b n.
(Applicative m, Monad m) =>
(a -> m b) -> [(n, a)] -> m [(n, b)]
mapAssocM Val -> TypeCheck Expr
reify [(Name, Val)]
rho
(VApp Val
v [Val]
vl) -> if (Int, Bool) -> Int
forall a b. (a, b) -> a
fst (Int, Bool)
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (Int, Bool) -> Bool
forall a b. (a, b) -> b
snd (Int, Bool)
m
then Val -> TypeCheck Val
force Val
v0 TypeCheck Val -> (Val -> TypeCheck Expr) -> TypeCheck 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
>>= (Int, Bool) -> Val -> TypeCheck Expr
reify' ((Int, Bool) -> Int
forall a b. (a, b) -> a
fst (Int, Bool)
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Bool
True)
else let m' :: (Int, Bool)
m' = ((Int, Bool) -> Int
forall a b. (a, b) -> a
fst (Int, Bool)
m, Bool
True) in
(Expr -> [Expr] -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 ((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) ((Int, Bool) -> Val -> TypeCheck Expr
reify' (Int, Bool)
m' Val
v) ((Val -> TypeCheck Expr)
-> [Val]
-> 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 ((Int, Bool) -> Val -> TypeCheck Expr
reify' (Int, Bool)
m') [Val]
vl)
(VCase Val
v Val
tv Env
rho [Clause]
cls) -> do
e <- Val -> TypeCheck Expr
reify Val
v
t <- reify tv
return $ Case e (Just t) cls
(Val
VIrr) -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Expr
Irr
Val
v -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck Expr
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
"Eval.reify" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
v StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"not implemented")
toExpr :: Val -> TypeCheck Expr
toExpr :: Val -> TypeCheck Expr
toExpr Val
v =
case Val
v of
VClos Env
rho Expr
e -> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e
Val
VZero -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Expr
Zero
Val
VInfty -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Expr
Infty
(VSucc Val
v) -> Expr -> Expr
Succ (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
toExpr Val
v
VMax [Val]
vs -> [Expr] -> Expr
maxE ([Expr] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> [Val]
-> 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 Val -> TypeCheck Expr
toExpr [Val]
vs
VPlus [Val]
vs -> [Expr] -> Expr
Plus ([Expr] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> [Val]
-> 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 Val -> TypeCheck Expr
toExpr [Val]
vs
VMeta Int
x Env
rho Int
n -> Int -> Env -> Int -> TypeCheck Expr
metaToExpr Int
x Env
rho Int
n
VSort Sort Val
s -> Sort Expr -> Expr
Sort (Sort Expr -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Sort Expr)
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> Sort Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Sort 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) -> Sort a -> m (Sort b)
mapM Val -> TypeCheck Expr
toExpr Sort Val
s
VMeasured Measure Val
mu Val
bv -> TBind -> Expr -> Expr
pi (TBind -> Expr -> Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Measure Expr -> TBind
forall a. Measure Expr -> TBinding a
TMeasure (Measure Expr -> TBind)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> Measure Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure 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) -> Measure a -> m (Measure b)
mapM Val -> TypeCheck Expr
toExpr Measure Val
mu) StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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
<*> Val -> TypeCheck Expr
toExpr Val
bv
VGuard Bound Val
beta Val
bv -> TBind -> Expr -> Expr
pi (TBind -> Expr -> Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bound Expr -> TBind
forall a. Bound Expr -> TBinding a
TBound (Bound Expr -> TBind)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> Bound Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound 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) -> Bound a -> m (Bound b)
mapM Val -> TypeCheck Expr
toExpr Bound Val
beta) StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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
<*> Val -> TypeCheck Expr
toExpr Val
bv
VBelow LtLe
Le Val
VInfty -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Size
VBelow LtLe
ltle Val
bv -> LtLe -> Expr -> Expr
Below LtLe
ltle (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
toExpr Val
bv
VQuant PiSigma
pisig Name
x Domain
dom Val
fv -> Name -> Val -> (Val -> Val -> TypeCheck Expr) -> TypeCheck Expr
forall a. Name -> Val -> (Val -> Val -> TypeCheck a) -> TypeCheck a
underAbs' Name
x Val
fv ((Val -> Val -> TypeCheck Expr) -> TypeCheck Expr)
-> (Val -> Val -> TypeCheck Expr) -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ \ Val
xv Val
bv ->
PiSigma -> TBind -> Expr -> Expr
piSig PiSigma
pisig (TBind -> Expr -> Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Dom Expr -> TBind)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Dom Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> Domain
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Dom 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) -> Dom a -> m (Dom b)
mapM Val -> TypeCheck Expr
toExpr Domain
dom) StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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
<*> Val -> TypeCheck Expr
toExpr Val
bv
VSing Val
v Val
tv -> Expr -> Expr -> Expr
Sing (Expr -> Expr -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
toExpr Val
v StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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
<*> Val -> TypeCheck Expr
toExpr Val
tv
Val
fv | Val -> Bool
isFun Val
fv -> Name -> (Val -> TypeCheck Expr) -> TypeCheck Expr
forall a.
Name
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Name -> (Val -> m a) -> m a
addName (Val -> Name
absName Val
fv) ((Val -> TypeCheck Expr) -> TypeCheck Expr)
-> (Val -> TypeCheck Expr) -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ \ Val
xv -> Val -> TypeCheck Expr
toExpr (Val -> TypeCheck Expr) -> TypeCheck Val -> TypeCheck Expr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> Val -> TypeCheck Val
app Val
fv Val
xv
VUp Val
v Val
tv -> Val -> TypeCheck Expr
toExpr Val
v
VGen Int
k -> Name -> Expr
Var (Name -> Expr)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
forall (m :: * -> *). MonadCxt m => Int -> m Name
nameOfGen Int
k
VDef DefId
d -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ DefId -> Expr
Def DefId
d
VProj PrePost
fx Name
n -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ PrePost -> Name -> Expr
Proj PrePost
fx Name
n
VPair Val
v1 Val
v2 -> Expr -> Expr -> Expr
Pair (Expr -> Expr -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
toExpr Val
v1 StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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
<*> Val -> TypeCheck Expr
toExpr Val
v2
VRecord RecInfo
ri [(Name, Val)]
rho -> RecInfo -> [(Name, Expr)] -> Expr
Record RecInfo
ri ([(Name, Expr)] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Expr)]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> TypeCheck Expr)
-> [(Name, Val)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Expr)]
forall (m :: * -> *) a b n.
(Applicative m, Monad m) =>
(a -> m b) -> [(n, a)] -> m [(n, b)]
mapAssocM Val -> TypeCheck Expr
toExpr [(Name, Val)]
rho
VApp Val
v [Val]
vl -> (Expr -> [Expr] -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 ((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) (Val -> TypeCheck Expr
toExpr Val
v) ((Val -> TypeCheck Expr)
-> [Val]
-> 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 Val -> TypeCheck Expr
toExpr [Val]
vl)
VCase Val
v Val
tv Env
rho [Clause]
cls -> Expr -> Maybe Expr -> [Clause] -> Expr
Case (Expr -> Maybe Expr -> [Clause] -> Expr)
-> TypeCheck Expr
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe Expr -> [Clause] -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
toExpr Val
v StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe Expr -> [Clause] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Expr)
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
([Clause] -> Expr)
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
<*> (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Expr
toExpr Val
tv) StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
([Clause] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
-> TypeCheck Expr
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)
-> [Clause]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Env
-> Clause
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause
clauseToExpr Env
rho) [Clause]
cls
Val
VIrr -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ Expr
Irr
addNameEnv :: Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
addNameEnv :: forall a.
Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
addNameEnv Name
x Env
rho Name -> Env -> TypeCheck a
cont = do
let dom' :: Domain
dom' = Val -> Domain
forall a. a -> Dom a
defaultDomain Val
VIrr
Name -> Domain -> (Int -> Val -> TypeCheck a) -> TypeCheck a
forall a.
Name
-> Domain
-> (Int
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (Int -> Val -> m a) -> m a
newWithGen Name
x Domain
dom' ((Int -> Val -> TypeCheck a) -> TypeCheck a)
-> (Int -> Val -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ \ Int
k Val
_ -> do
x' <- Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
forall (m :: * -> *). MonadCxt m => Int -> m Name
nameOfGen Int
k
cont x' (update rho x (VGen k))
addPatternEnv :: Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv :: forall a.
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv Pattern
p Env
rho Pattern -> Env -> TypeCheck a
cont =
case Pattern
p of
VarP Name
x -> Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
addNameEnv Name
x Env
rho ((Name -> Env -> TypeCheck a) -> TypeCheck a)
-> (Name -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ Pattern -> Env -> TypeCheck a
cont (Pattern -> Env -> TypeCheck a)
-> (Name -> Pattern) -> Name -> Env -> TypeCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Pattern
forall e. Name -> Pat e
VarP
SizeP Expr
e Name
x -> Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
addNameEnv Name
x Env
rho ((Name -> Env -> TypeCheck a) -> TypeCheck a)
-> (Name -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ Pattern -> Env -> TypeCheck a
cont (Pattern -> Env -> TypeCheck a)
-> (Name -> Pattern) -> Name -> Env -> TypeCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Pattern
forall e. Name -> Pat e
VarP
PairP Pattern
p1 Pattern
p2 -> Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv Pattern
p1 Env
rho ((Pattern -> Env -> TypeCheck a) -> TypeCheck a)
-> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ \ Pattern
p1 Env
rho ->
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv Pattern
p2 Env
rho ((Pattern -> Env -> TypeCheck a) -> TypeCheck a)
-> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ \ Pattern
p2 Env
rho -> Pattern -> Env -> TypeCheck a
cont (Pattern -> Pattern -> Pattern
forall e. Pat e -> Pat e -> Pat e
PairP Pattern
p1 Pattern
p2) Env
rho
ConP PatternInfo
pi QName
n [Pattern]
ps -> [Pattern]
-> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
forall a.
[Pattern]
-> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
addPatternsEnv [Pattern]
ps Env
rho (([Pattern] -> Env -> TypeCheck a) -> TypeCheck a)
-> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ Pattern -> Env -> TypeCheck a
cont (Pattern -> Env -> TypeCheck a)
-> ([Pattern] -> Pattern) -> [Pattern] -> Env -> TypeCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP PatternInfo
pi QName
n
SuccP Pattern
p -> Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv Pattern
p Env
rho ((Pattern -> Env -> TypeCheck a) -> TypeCheck a)
-> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ Pattern -> Env -> TypeCheck a
cont (Pattern -> Env -> TypeCheck a)
-> (Pattern -> Pattern) -> Pattern -> Env -> TypeCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Pattern
forall e. Pat e -> Pat e
SuccP
UnusableP Pattern
p -> Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv Pattern
p Env
rho ((Pattern -> Env -> TypeCheck a) -> TypeCheck a)
-> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ Pattern -> Env -> TypeCheck a
cont (Pattern -> Env -> TypeCheck a)
-> (Pattern -> Pattern) -> Pattern -> Env -> TypeCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Pattern
forall e. Pat e -> Pat e
UnusableP
DotP Expr
e -> do { e <- Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e ; cont (DotP e) rho }
Pattern
AbsurdP -> Pattern -> Env -> TypeCheck a
cont Pattern
forall e. Pat e
AbsurdP Env
rho
ErasedP Pattern
p -> Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv Pattern
p Env
rho ((Pattern -> Env -> TypeCheck a) -> TypeCheck a)
-> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ Pattern -> Env -> TypeCheck a
cont (Pattern -> Env -> TypeCheck a)
-> (Pattern -> Pattern) -> Pattern -> Env -> TypeCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Pattern
forall e. Pat e -> Pat e
ErasedP
addPatternsEnv :: [Pattern] -> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
addPatternsEnv :: forall a.
[Pattern]
-> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
addPatternsEnv [] Env
rho [Pattern] -> Env -> TypeCheck a
cont = [Pattern] -> Env -> TypeCheck a
cont [] Env
rho
addPatternsEnv (Pattern
p:[Pattern]
ps) Env
rho [Pattern] -> Env -> TypeCheck a
cont =
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a.
Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
addPatternEnv Pattern
p Env
rho ((Pattern -> Env -> TypeCheck a) -> TypeCheck a)
-> (Pattern -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ \ Pattern
p Env
rho ->
[Pattern]
-> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
forall a.
[Pattern]
-> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
addPatternsEnv [Pattern]
ps Env
rho (([Pattern] -> Env -> TypeCheck a) -> TypeCheck a)
-> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ \ [Pattern]
ps Env
rho ->
[Pattern] -> Env -> TypeCheck a
cont (Pattern
pPattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
:[Pattern]
ps) Env
rho
class ClosToExpr a where
closToExpr :: Env -> a -> TypeCheck a
bindClosToExpr :: Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b
closToExpr Env
rho a
a = Env -> a -> (Env -> a -> TypeCheck a) -> TypeCheck a
forall b. Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b
forall a b.
ClosToExpr a =>
Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b
bindClosToExpr Env
rho a
a ((Env -> a -> TypeCheck a) -> TypeCheck a)
-> (Env -> a -> TypeCheck a) -> TypeCheck a
forall a b. (a -> b) -> a -> b
$ \ Env
rho a
a -> a -> TypeCheck a
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
bindClosToExpr Env
rho a
a Env -> a -> TypeCheck b
cont = Env -> a -> TypeCheck b
cont Env
rho (a -> TypeCheck b) -> TypeCheck a -> TypeCheck b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> a -> TypeCheck a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho a
a
instance ClosToExpr a => ClosToExpr [a] where
closToExpr :: Env -> [a] -> TypeCheck [a]
closToExpr = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> [a] -> TypeCheck [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> [a] -> TypeCheck [a])
-> (Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Env
-> [a]
-> TypeCheck [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr
instance ClosToExpr a => ClosToExpr (Maybe a) where
closToExpr :: Env -> Maybe a -> TypeCheck (Maybe a)
closToExpr = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Maybe a -> TypeCheck (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Maybe a -> TypeCheck (Maybe a))
-> (Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Env
-> Maybe a
-> TypeCheck (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr
instance ClosToExpr a => ClosToExpr (Dom a) where
closToExpr :: Env -> Dom a -> TypeCheck (Dom a)
closToExpr = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Dom a -> TypeCheck (Dom a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dom a -> f (Dom b)
traverse ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Dom a -> TypeCheck (Dom a))
-> (Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Env
-> Dom a
-> TypeCheck (Dom a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr
instance ClosToExpr a => ClosToExpr (Sort a) where
closToExpr :: Env -> Sort a -> TypeCheck (Sort a)
closToExpr = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Sort a -> TypeCheck (Sort a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Sort a -> f (Sort b)
traverse ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Sort a -> TypeCheck (Sort a))
-> (Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Env
-> Sort a
-> TypeCheck (Sort a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr
instance ClosToExpr a => ClosToExpr (Measure a) where
closToExpr :: Env -> Measure a -> TypeCheck (Measure a)
closToExpr = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Measure a -> TypeCheck (Measure a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Measure a -> f (Measure b)
traverse ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Measure a -> TypeCheck (Measure a))
-> (Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Env
-> Measure a
-> TypeCheck (Measure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr
instance ClosToExpr a => ClosToExpr (Bound a) where
closToExpr :: Env -> Bound a -> TypeCheck (Bound a)
closToExpr = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Bound a -> TypeCheck (Bound a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
traverse ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Bound a -> TypeCheck (Bound a))
-> (Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Env
-> Bound a
-> TypeCheck (Bound a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr
instance ClosToExpr a => ClosToExpr (Tagged a) where
closToExpr :: Env -> Tagged a -> TypeCheck (Tagged a)
closToExpr = (a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Tagged a -> TypeCheck (Tagged a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tagged a -> f (Tagged b)
traverse ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Tagged a -> TypeCheck (Tagged a))
-> (Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> Env
-> Tagged a
-> TypeCheck (Tagged a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr
instance ClosToExpr a => ClosToExpr (TBinding a) where
bindClosToExpr :: forall b.
Env
-> TBinding a -> (Env -> TBinding a -> TypeCheck b) -> TypeCheck b
bindClosToExpr Env
rho (TBind Name
x Dom a
a) Env -> TBinding a -> TypeCheck b
cont = do
a <- Env -> Dom a -> TypeCheck (Dom a)
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Dom a
a
addNameEnv x rho $ \ Name
x Env
rho -> Env -> TBinding a -> TypeCheck b
cont Env
rho (TBinding a -> TypeCheck b) -> TBinding a -> TypeCheck b
forall a b. (a -> b) -> a -> b
$ Name -> Dom a -> TBinding a
forall a. Name -> Dom a -> TBinding a
TBind Name
x Dom a
a
bindClosToExpr Env
rho (TMeasure Measure Expr
mu) Env -> TBinding a -> TypeCheck b
cont = Env -> TBinding a -> TypeCheck b
cont Env
rho (TBinding a -> TypeCheck b)
-> (Measure Expr -> TBinding a) -> Measure Expr -> TypeCheck b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measure Expr -> TBinding a
forall a. Measure Expr -> TBinding a
TMeasure (Measure Expr -> TypeCheck b)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure Expr)
-> TypeCheck b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env
-> Measure Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Measure Expr)
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Measure Expr
mu
bindClosToExpr Env
rho (TBound Bound Expr
beta) Env -> TBinding a -> TypeCheck b
cont = Env -> TBinding a -> TypeCheck b
cont Env
rho (TBinding a -> TypeCheck b)
-> (Bound Expr -> TBinding a) -> Bound Expr -> TypeCheck b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bound Expr -> TBinding a
forall a. Bound Expr -> TBinding a
TBound (Bound Expr -> TypeCheck b)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound Expr)
-> TypeCheck b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env
-> Bound Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Bound Expr)
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Bound Expr
beta
instance ClosToExpr Telescope where
bindClosToExpr :: forall b.
Env
-> Telescope -> (Env -> Telescope -> TypeCheck b) -> TypeCheck b
bindClosToExpr Env
rho (Telescope [TBind]
tel) Env -> Telescope -> TypeCheck b
cont = Env -> [TBind] -> (Env -> [TBind] -> TypeCheck b) -> TypeCheck b
forall {a} {b}.
ClosToExpr a =>
Env -> [a] -> (Env -> [a] -> TypeCheck b) -> TypeCheck b
loop Env
rho [TBind]
tel ((Env -> [TBind] -> TypeCheck b) -> TypeCheck b)
-> (Env -> [TBind] -> TypeCheck b) -> TypeCheck b
forall a b. (a -> b) -> a -> b
$ \ Env
rho -> Env -> Telescope -> TypeCheck b
cont Env
rho (Telescope -> TypeCheck b)
-> ([TBind] -> Telescope) -> [TBind] -> TypeCheck b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TBind] -> Telescope
Telescope
where
loop :: Env -> [a] -> (Env -> [a] -> TypeCheck b) -> TypeCheck b
loop Env
rho [] Env -> [a] -> TypeCheck b
cont = Env -> [a] -> TypeCheck b
cont Env
rho []
loop Env
rho (a
tb : [a]
tel) Env -> [a] -> TypeCheck b
cont = Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b
forall b. Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b
forall a b.
ClosToExpr a =>
Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b
bindClosToExpr Env
rho a
tb ((Env -> a -> TypeCheck b) -> TypeCheck b)
-> (Env -> a -> TypeCheck b) -> TypeCheck b
forall a b. (a -> b) -> a -> b
$ \ Env
rho a
tb ->
Env -> [a] -> (Env -> [a] -> TypeCheck b) -> TypeCheck b
loop Env
rho [a]
tel ((Env -> [a] -> TypeCheck b) -> TypeCheck b)
-> (Env -> [a] -> TypeCheck b) -> TypeCheck b
forall a b. (a -> b) -> a -> b
$ \ Env
rho [a]
tel -> Env -> [a] -> TypeCheck b
cont Env
rho ([a] -> TypeCheck b) -> [a] -> TypeCheck b
forall a b. (a -> b) -> a -> b
$ a
tb a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tel
instance ClosToExpr Expr where
closToExpr :: Env -> Expr -> TypeCheck Expr
closToExpr Env
rho Expr
e =
case Expr
e of
Sort Sort Expr
s -> Sort Expr -> Expr
Sort (Sort Expr -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Sort Expr)
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> Sort Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Sort Expr)
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Sort Expr
s
Expr
Zero -> Expr -> TypeCheck 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) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e
Expr
Infty -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
Max [Expr]
es -> [Expr] -> Expr
Max ([Expr] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> [Expr]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho [Expr]
es
Plus [Expr]
es -> [Expr] -> Expr
Plus ([Expr] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> [Expr]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Expr]
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho [Expr]
es
Meta Int
x -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
Var Name
x -> Val -> TypeCheck Expr
toExpr (Val -> TypeCheck Expr) -> TypeCheck Val -> TypeCheck Expr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Expr -> TypeCheck Val
whnf Env
rho Expr
e
Def DefId
d -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
Case Expr
e Maybe Expr
mt [Clause]
cls -> Expr -> Maybe Expr -> [Clause] -> Expr
Case (Expr -> Maybe Expr -> [Clause] -> Expr)
-> TypeCheck Expr
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe Expr -> [Clause] -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe Expr -> [Clause] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Expr)
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
([Clause] -> Expr)
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
-> Maybe Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Expr)
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Maybe Expr
mt StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
([Clause] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
-> TypeCheck Expr
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)
-> [Clause]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Env
-> Clause
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause
clauseToExpr Env
rho) [Clause]
cls
LLet LBind
tb Telescope
tel Expr
e1 Expr
e2 | Telescope -> Bool
forall a. Null a => a -> Bool
null Telescope
tel -> do
e1 <- Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e1
bindClosToExpr rho tb $ \ Env
rho LBind
tb -> LBind -> Telescope -> Expr -> Expr -> Expr
LLet LBind
tb Telescope
tel Expr
e1 (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e2
Proj PrePost
fx Name
n -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
Record RecInfo
ri [(Name, Expr)]
rs -> RecInfo -> [(Name, Expr)] -> Expr
Record RecInfo
ri ([(Name, Expr)] -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Expr)]
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> TypeCheck Expr)
-> [(Name, Expr)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Expr)]
forall (m :: * -> *) a b n.
(Applicative m, Monad m) =>
(a -> m b) -> [(n, a)] -> m [(n, b)]
mapAssocM (Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho) [(Name, Expr)]
rs
Pair Expr
e1 Expr
e2 -> Expr -> Expr -> Expr
Pair (Expr -> Expr -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e1 StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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 -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e2
App Expr
e1 Expr
e2 -> Expr -> Expr -> Expr
App (Expr -> Expr -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e1 StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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 -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e2
Lam Dec
dec Name
x Expr
e -> Name -> Env -> (Name -> Env -> TypeCheck Expr) -> TypeCheck Expr
forall a.
Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
addNameEnv Name
x Env
rho ((Name -> Env -> TypeCheck Expr) -> TypeCheck Expr)
-> (Name -> Env -> TypeCheck Expr) -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ \ Name
x Env
rho ->
Dec -> Name -> Expr -> Expr
Lam Dec
dec Name
x (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e
Below LtLe
ltle Expr
e -> LtLe -> Expr -> Expr
Below LtLe
ltle (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e
Quant PiSigma
piSig TBind
tb Expr
e -> Env -> TBind -> (Env -> TBind -> TypeCheck Expr) -> TypeCheck Expr
forall b.
Env -> TBind -> (Env -> TBind -> TypeCheck b) -> TypeCheck b
forall a b.
ClosToExpr a =>
Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b
bindClosToExpr Env
rho TBind
tb ((Env -> TBind -> TypeCheck Expr) -> TypeCheck Expr)
-> (Env -> TBind -> TypeCheck Expr) -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ \ Env
rho TBind
tb -> PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
piSig TBind
tb (Expr -> Expr) -> TypeCheck Expr -> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e
Sing Expr
e1 Expr
e2 -> Expr -> Expr -> Expr
Sing (Expr -> Expr -> Expr)
-> TypeCheck Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e1 StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Expr -> Expr)
-> TypeCheck Expr -> TypeCheck Expr
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 -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Expr
e2
Ann Tagged Expr
taggedE -> Tagged Expr -> Expr
Ann (Tagged Expr -> Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Tagged Expr)
-> TypeCheck Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> Tagged Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Tagged Expr)
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho Tagged Expr
taggedE
Expr
Irr -> Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
metaToExpr :: Int -> Env -> Int -> TypeCheck Expr
metaToExpr :: Int -> Env -> Int -> TypeCheck Expr
metaToExpr Int
x Env
rho Int
k = Expr -> TypeCheck Expr
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TypeCheck Expr) -> Expr -> TypeCheck Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> Expr -> [Expr]
forall a. (a -> a) -> a -> [a]
iterate Expr -> Expr
Succ (Int -> Expr
Meta Int
x) [Expr] -> Int -> Expr
forall a. HasCallStack => [a] -> Int -> a
!! Int
k
clauseToExpr :: Env -> Clause -> TypeCheck Clause
clauseToExpr :: Env
-> Clause
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause
clauseToExpr Env
rho (Clause TeleVal
vtel [Pattern]
ps Maybe Expr
me) = [Pattern]
-> Env
-> ([Pattern]
-> Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause
forall a.
[Pattern]
-> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a
addPatternsEnv [Pattern]
ps Env
rho (([Pattern]
-> Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause)
-> ([Pattern]
-> Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause
forall a b. (a -> b) -> a -> b
$ \ [Pattern]
ps Env
rho ->
TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
vtel [Pattern]
ps (Maybe Expr -> Clause)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Expr)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Clause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> TypeCheck Expr)
-> Maybe Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe 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) -> Maybe a -> m (Maybe b)
mapM (Env -> Expr -> TypeCheck Expr
forall a. ClosToExpr a => Env -> a -> TypeCheck a
closToExpr Env
rho) Maybe Expr
me
whnf :: Env -> Expr -> TypeCheck Val
whnf :: Env -> Expr -> TypeCheck Val
whnf Env
env Expr
e = String -> TypeCheck Val -> TypeCheck Val
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (String
"whnf " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e) (TypeCheck Val -> TypeCheck Val) -> TypeCheck Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$
case Expr
e of
Meta Int
i -> do let v :: Val
v = Int -> Env -> Int -> Val
VMeta Int
i Env
env Int
0
String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceMetaM (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"whnf meta " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v
Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v
LLet (TBind Name
x Dom (Maybe Expr)
dom) Telescope
tel Expr
e1 Expr
e2 | Telescope -> Bool
forall a. Null a => a -> Bool
null Telescope
tel -> do
let v1 :: Val
v1 = Env -> Expr -> Val
mkClos Env
env Expr
e1
Env -> Expr -> TypeCheck Val
whnf (Env -> Name -> Val -> Env
forall a. Environ a -> Name -> a -> Environ a
update Env
env Name
x Val
v1) Expr
e2
Lam Dec
dec Name
x Expr
e1 -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Name -> Env -> Expr -> Val
vLam Name
x Env
env Expr
e1
Below LtLe
ltle Expr
e -> LtLe -> Val -> Val
VBelow LtLe
ltle (Val -> Val) -> TypeCheck Val -> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Val
whnf Env
env Expr
e
Quant PiSigma
pisig (TBind Name
x Dom Expr
dom) Expr
b -> do
dom' <- (Expr -> TypeCheck Val)
-> Dom Expr
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) Domain
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)
mapM (Env -> Expr -> TypeCheck Val
whnf Env
env) Dom Expr
dom
return $ VQuant pisig x dom' $ vLam x env b
Quant PiSigma
Pi (TMeasure Measure Expr
mu) Expr
b -> do
muv <- Env -> Measure Expr -> TypeCheck (Measure Val)
whnfMeasure Env
env Measure Expr
mu
bv <- whnf env b
case (envBound env) of
Maybe (Measure Val)
Nothing -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Measure Val -> Val -> Val
VMeasured Measure Val
muv Val
bv
Just Measure Val
muv' -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Bound Val -> Val -> Val
VGuard (LtLe -> Measure Val -> Measure Val -> Bound Val
forall a. LtLe -> Measure a -> Measure a -> Bound a
Bound LtLe
Lt Measure Val
muv Measure Val
muv') Val
bv
Quant PiSigma
Pi (TBound (Bound LtLe
ltle Measure Expr
mu Measure Expr
mu')) Expr
b -> do
muv <- Env -> Measure Expr -> TypeCheck (Measure Val)
whnfMeasure Env
env Measure Expr
mu
muv' <- whnfMeasure env mu'
bv <- whnf env b
return $ VGuard (Bound ltle muv muv') bv
Sing Expr
e Expr
t -> do tv <- Env -> Expr -> TypeCheck Val
whnf Env
env Expr
t
sing env e tv
Pair Expr
e1 Expr
e2 -> Val -> Val -> Val
VPair (Val -> Val -> Val)
-> TypeCheck Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr -> TypeCheck Val
whnf Env
env Expr
e1 StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Val -> Val)
-> TypeCheck Val -> TypeCheck Val
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 -> Expr -> TypeCheck Val
whnf Env
env Expr
e2
Proj PrePost
fx Name
n -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ PrePost -> Name -> Val
VProj PrePost
fx Name
n
Record ri :: RecInfo
ri@(NamedRec ConK
Cons QName
_ Bool
_ Dotted
_) [(Name, Expr)]
rs -> RecInfo -> [(Name, Val)] -> Val
VRecord RecInfo
ri ([(Name, Val)] -> Val)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
-> TypeCheck Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> TypeCheck Val)
-> [(Name, Expr)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
forall (m :: * -> *) a b n.
(Applicative m, Monad m) =>
(a -> m b) -> [(n, a)] -> m [(n, b)]
mapAssocM (Env -> Expr -> TypeCheck Val
whnf Env
env) [(Name, Expr)]
rs
Record RecInfo
ri [(Name, Expr)]
rs -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ RecInfo -> [(Name, Val)] -> Val
VRecord RecInfo
ri ([(Name, Val)] -> Val) -> [(Name, Val)] -> Val
forall a b. (a -> b) -> a -> b
$ (Expr -> Val) -> [(Name, Expr)] -> [(Name, Val)]
forall a b n. (a -> b) -> [(n, a)] -> [(n, b)]
mapAssoc (Env -> Expr -> Val
mkClos Env
env) [(Name, Expr)]
rs
App Expr
f Expr
e -> do vf <- Env -> Expr -> TypeCheck Val
whnf Env
env Expr
f
let ve = Env -> Expr -> Val
mkClos Env
env Expr
e
app vf ve
Case Expr
e (Just Expr
t) [Clause]
cs -> do
v <- Env -> Expr -> TypeCheck Val
whnf Env
env Expr
e
vt <- whnf env t
evalCase v vt env cs
Sort Sort Expr
s -> Env -> Sort Expr -> TypeCheck (Sort Val)
whnfSort Env
env Sort Expr
s TypeCheck (Sort Val)
-> (Sort Val -> TypeCheck Val) -> TypeCheck Val
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
>>= Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val)
-> (Sort Val -> Val) -> Sort Val -> TypeCheck Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sort Val -> Val
vSort
Expr
Infty -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
VInfty
Expr
Zero -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
VZero
Succ Expr
e1 -> do v <- Env -> Expr -> TypeCheck Val
whnf Env
env Expr
e1
return $ succSize v
Max [Expr]
es -> do vs <- (Expr -> TypeCheck Val)
-> [Expr]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Val]
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 (Env -> Expr -> TypeCheck Val
whnf Env
env) [Expr]
es
return $ maxSize vs
Plus [Expr]
es -> do vs <- (Expr -> TypeCheck Val)
-> [Expr]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Val]
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 (Env -> Expr -> TypeCheck Val
whnf Env
env) [Expr]
es
return $ plusSizes vs
Def (DefId IdKind
LetK QName
n) -> do
item <- QName
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
whnfClos (definingVal item)
Def (DefId (ConK ConK
DefPat) QName
n) -> Val -> TypeCheck Val
whnfClos (Val -> TypeCheck Val)
-> (SigDef -> Val) -> SigDef -> TypeCheck Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigDef -> Val
definingVal (SigDef -> TypeCheck Val)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
-> TypeCheck Val
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
n
Def DefId
id -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ DefId -> Val
vDef DefId
id
Var Name
y -> Env -> Name -> TypeCheck Val
forall (m :: * -> *) a.
MonadError TraceError m =>
Environ a -> Name -> m a
lookupEnv Env
env Name
y TypeCheck Val -> (Val -> TypeCheck Val) -> TypeCheck Val
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
>>= Val -> TypeCheck Val
whnfClos
Ann Tagged Expr
e -> Env -> Expr -> TypeCheck Val
whnf Env
env (Tagged Expr -> Expr
forall a. Tagged a -> a
unTag Tagged Expr
e)
Expr
Irr -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
VIrr
Expr
e -> String -> TypeCheck Val
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck Val) -> String -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ String
"NYI whnf " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e
whnfMeasure :: Env -> Measure Expr -> TypeCheck (Measure Val)
whnfMeasure :: Env -> Measure Expr -> TypeCheck (Measure Val)
whnfMeasure Env
rho (Measure [Expr]
mu) = (Expr -> TypeCheck Val)
-> [Expr]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Val]
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 (Env -> Expr -> TypeCheck Val
whnf Env
rho) [Expr]
mu StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Val]
-> ([Val] -> TypeCheck (Measure Val)) -> TypeCheck (Measure Val)
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
>>= Measure Val -> TypeCheck (Measure Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Measure Val -> TypeCheck (Measure Val))
-> ([Val] -> Measure Val) -> [Val] -> TypeCheck (Measure Val)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> Measure Val
forall a. [a] -> Measure a
Measure
whnfSort :: Env -> Sort Expr -> TypeCheck (Sort Val)
whnfSort :: Env -> Sort Expr -> TypeCheck (Sort Val)
whnfSort Env
rho (SortC Class
c) = Sort Val -> TypeCheck (Sort Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort Val -> TypeCheck (Sort Val))
-> Sort Val -> TypeCheck (Sort Val)
forall a b. (a -> b) -> a -> b
$ Class -> Sort Val
forall a. Class -> Sort a
SortC Class
c
whnfSort Env
rho (CoSet Expr
e) = Env -> Expr -> TypeCheck Val
whnf Env
rho Expr
e TypeCheck Val
-> (Val -> TypeCheck (Sort Val)) -> TypeCheck (Sort Val)
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
>>= Sort Val -> TypeCheck (Sort Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort Val -> TypeCheck (Sort Val))
-> (Val -> Sort Val) -> Val -> TypeCheck (Sort Val)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Sort Val
forall a. a -> Sort a
CoSet
whnfSort Env
rho (Set Expr
e) = Env -> Expr -> TypeCheck Val
whnf Env
rho Expr
e TypeCheck Val
-> (Val -> TypeCheck (Sort Val)) -> TypeCheck (Sort Val)
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
>>= Sort Val -> TypeCheck (Sort Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort Val -> TypeCheck (Sort Val))
-> (Val -> Sort Val) -> Val -> TypeCheck (Sort Val)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Sort Val
forall a. a -> Sort a
Set
whnfClos :: Clos -> TypeCheck Val
whnfClos :: Val -> TypeCheck Val
whnfClos Val
v =
case Val
v of
(VClos Env
e Expr
rho) -> Env -> Expr -> TypeCheck Val
whnf Env
e Expr
rho
(VApp (VDef (DefId IdKind
FunK QName
n)) [Val]
vl) -> QName -> [Val] -> TypeCheck Val
appDef QName
n [Val]
vl
Val
v -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v
whnf' :: Expr -> TypeCheck Val
whnf' :: Expr -> TypeCheck Val
whnf' Expr
e = do
env <- TypeCheck Env
forall (m :: * -> *). MonadCxt m => m Env
getEnv
whnf env e
sing :: Env -> Expr -> TVal -> TypeCheck TVal
sing :: Env -> Expr -> Val -> TypeCheck Val
sing Env
rho Expr
e Val
tv = do
let v :: Val
v = Env -> Expr -> Val
mkClos Env
rho Expr
e
Val -> Val -> TypeCheck Val
vSing Val
v Val
tv
sing' :: Expr -> TVal -> TypeCheck TVal
sing' :: Expr -> Val -> TypeCheck Val
sing' Expr
e Val
tv = do
env <- TypeCheck Env
forall (m :: * -> *). MonadCxt m => m Env
getEnv
sing env e tv
evalCase :: Val -> TVal -> Env -> [Clause] -> TypeCheck Val
evalCase :: Val -> Val -> Env -> [Clause] -> TypeCheck Val
evalCase Val
v Val
tv Env
env [Clause]
cs = do
m <- Env -> [Clause] -> [Val] -> TypeCheck (Maybe Val)
matchClauses Env
env [Clause]
cs [Val
v]
case m of
Maybe Val
Nothing -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Env -> [Clause] -> Val
VCase Val
v Val
tv Env
env [Clause]
cs
Just Val
v' -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val
v'
piApp :: TVal -> Clos -> TypeCheck TVal
piApp :: Val -> Val -> TypeCheck Val
piApp (VGuard Bound Val
beta Val
bv) Val
w = Val -> Val -> TypeCheck Val
piApp Val
bv Val
w
piApp (VQuant PiSigma
Pi Name
x Domain
dom Val
fv) Val
w = Val -> Val -> TypeCheck Val
app Val
fv Val
w
piApp tv :: Val
tv@(VApp (VDef (DefId IdKind
DatK QName
n)) [Val]
vl) (VProj PrePost
Post Name
p) = Val -> Name -> Val -> TypeCheck Val
projectType Val
tv Name
p Val
VIrr
piApp Val
tv Val
w = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck Val
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
"piApp: IMPOSSIBLE to instantiate" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
"to argument" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
w)
piApps :: TVal -> [Clos] -> TypeCheck TVal
piApps :: Val -> [Val] -> TypeCheck Val
piApps Val
tv [] = Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
tv
piApps Val
tv (Val
v:[Val]
vs) = do tv' <- Val -> Val -> TypeCheck Val
piApp Val
tv Val
v
piApps tv' vs
updateValu :: Valuation -> Int -> Val -> TypeCheck Valuation
updateValu :: Valuation -> Int -> Val -> TypeCheck Valuation
updateValu Valuation
valu Int
i Val
v = Valuation -> Valuation -> TypeCheck Valuation
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' (Int -> Val -> Valuation
sgVal Int
i Val
v) Valuation
valu
app :: Val -> Clos -> TypeCheck Val
app :: Val -> Val -> TypeCheck Val
app = Bool -> Val -> Val -> TypeCheck Val
app' Bool
True
app' :: Bool -> Val -> Clos -> TypeCheck Val
app' :: Bool -> Val -> Val -> TypeCheck Val
app' Bool
expandDefs Val
u Val
v = do
let app :: Val -> Val -> TypeCheck Val
app = Bool -> Val -> Val -> TypeCheck Val
app' Bool
expandDefs
appDef' :: Bool -> QName -> [Val] -> TypeCheck Val
appDef' Bool
True QName
f [Val]
vs = QName -> [Val] -> TypeCheck Val
appDef QName
f [Val]
vs
appDef' Bool
False QName
f [Val]
vs = Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ DefId -> Val
VDef (IdKind -> QName -> DefId
DefId IdKind
FunK QName
f) Val -> [Val] -> Val
`VApp` [Val]
vs
appDef_ :: QName -> [Val] -> TypeCheck Val
appDef_ = Bool -> QName -> [Val] -> TypeCheck Val
appDef' Bool
expandDefs
case Val
u of
VProj PrePost
Pre Name
n -> (Val -> Val -> TypeCheck Val) -> Val -> Val -> TypeCheck Val
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool -> Val -> Val -> TypeCheck Val
app' Bool
expandDefs) (PrePost -> Name -> Val
VProj PrePost
Post Name
n) (Val -> TypeCheck Val) -> TypeCheck Val -> TypeCheck Val
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> TypeCheck Val
whnfClos Val
v
VRecord RecInfo
ri [(Name, Val)]
rho -> do
let VProj PrePost
Post Name
n = Val
v
TypeCheck Val
-> (Val -> TypeCheck Val) -> Maybe Val -> TypeCheck Val
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> TypeCheck Val
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck Val) -> String -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ String
"app: projection " 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
" not found in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
u)
Val -> TypeCheck Val
whnfClos (Name -> [(Name, Val)] -> Maybe Val
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Val)]
rho)
VDef (DefId IdKind
FunK QName
n) -> QName -> [Val] -> TypeCheck Val
appDef_ QName
n [Val
v]
VApp (VDef (DefId IdKind
FunK QName
n)) [Val]
vl -> QName -> [Val] -> TypeCheck Val
appDef_ QName
n ([Val]
vl [Val] -> [Val] -> [Val]
forall a. [a] -> [a] -> [a]
++ [Val
v])
VApp h :: Val
h@(VDef (DefId (ConK ConK
Cons) QName
n)) [Val]
vl -> do
v <- Val -> TypeCheck Val
whnfClos Val
v
return $ VApp h (vl ++ [v])
VApp Val
v1 [Val]
vl -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> [Val] -> Val
VApp Val
v1 ([Val]
vl [Val] -> [Val] -> [Val]
forall a. [a] -> [a] -> [a]
++ [Val
v])
VLam Name
x Env
env Expr
e -> Env -> Expr -> TypeCheck Val
whnf (Env -> Name -> Val -> Env
forall a. Environ a -> Name -> a -> Environ a
update Env
env Name
x Val
v) Expr
e
VConst Val
u -> Val -> TypeCheck Val
whnfClos Val
u
VAbs Name
x Int
i Val
u Valuation
valu -> (Valuation -> Val -> TypeCheck Val)
-> Val -> Valuation -> TypeCheck Val
forall a b c. (a -> b -> c) -> b -> a -> c
flip Valuation -> Val -> TypeCheck Val
forall a. Reval a => Valuation -> a -> TypeCheck a
reval' Val
u (Valuation -> TypeCheck Val)
-> TypeCheck Valuation -> TypeCheck Val
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Valuation -> Int -> Val -> TypeCheck Valuation
updateValu Valuation
valu Int
i Val
v
VUp Val
u (VQuant PiSigma
Pi Name
x Domain
dom Val
fu) -> Bool -> Val -> Val -> TypeCheck Val
up Bool
False (Val -> Val -> TypeCheck Val)
-> (TypeCheck Val, TypeCheck Val) -> TypeCheck Val
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (Val -> Val -> TypeCheck Val
app Val
u Val
v, Val -> Val -> TypeCheck Val
app Val
fu Val
v)
VUp Val
u1 (VApp (VDef (DefId IdKind
DatK QName
n)) [Val]
vl) -> do
u' <- Val -> TypeCheck Val
force Val
u
app u' v
Val
VIrr -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
VIrr
Val
_ -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> [Val] -> Val
VApp Val
u [Val
v]
force' :: Bool -> Val -> TypeCheck (Bool, Val)
force' :: Bool -> Val -> TypeCheck (Bool, Val)
force' Bool
b (VSing Val
v Val
tv) = do
(b',tv') <- Bool -> Val -> TypeCheck (Bool, Val)
force' Bool
b Val
tv
return (b', VSing v tv')
force' Bool
b (VUp Val
v Val
tv) = Bool -> Val -> Val -> TypeCheck Val
up Bool
True Val
v Val
tv TypeCheck Val
-> (Val -> TypeCheck (Bool, Val)) -> TypeCheck (Bool, Val)
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
>>= \ Val
v' -> (Bool, Val) -> TypeCheck (Bool, Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Val
v')
force' Bool
b (VClos Env
rho Expr
e) = do
v <- Env -> Expr -> TypeCheck Val
whnf Env
rho Expr
e
force' b v
force' Bool
b v :: Val
v@(VDef (DefId IdKind
FunK QName
n)) = Val -> TypeCheck (Bool, Val)
forall (m :: * -> *) a. MonadError TraceError m => Val -> m a
failValInv Val
v
force' Bool
b v :: Val
v@(VApp (VDef (DefId IdKind
FunK QName
n)) [Val]
vl) = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
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
"force" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
v) (TypeCheck (Bool, Val) -> TypeCheck (Bool, Val))
-> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
forall a b. (a -> b) -> a -> b
$
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
case Map.lookup n sig of
Just (FunSig Co
isCo Val
t Kind
ki Arity
ar [Clause]
cl Bool
True Expr
_) -> String -> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
forall a. String -> a -> a
traceMatch (String
"forcing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v) (TypeCheck (Bool, Val) -> TypeCheck (Bool, Val))
-> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
forall a b. (a -> b) -> a -> b
$
do m <- Env -> [Clause] -> [Val] -> TypeCheck (Maybe Val)
matchClauses Env
forall a. Environ a
emptyEnv [Clause]
cl [Val]
vl
case m of
Just Val
v' -> String -> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
forall a. String -> a -> a
traceMatch (String
"forcing " 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
" succeeded") (TypeCheck (Bool, Val) -> TypeCheck (Bool, Val))
-> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
forall a b. (a -> b) -> a -> b
$
Bool -> Val -> TypeCheck (Bool, Val)
force' Bool
True Val
v'
Maybe Val
Nothing -> String -> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
forall a. String -> a -> a
traceMatch (String
"forcing " 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
" failed") (TypeCheck (Bool, Val) -> TypeCheck (Bool, Val))
-> TypeCheck (Bool, Val) -> TypeCheck (Bool, Val)
forall a b. (a -> b) -> a -> b
$
(Bool, Val) -> TypeCheck (Bool, Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, Val
v)
Maybe SigDef
_ -> (Bool, Val) -> TypeCheck (Bool, Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, Val
v)
force' Bool
b Val
v = (Bool, Val) -> TypeCheck (Bool, Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, Val
v)
force :: Val -> TypeCheck Val
force :: Val -> TypeCheck Val
force Val
v =
((Bool, Val) -> Val) -> TypeCheck (Bool, Val) -> TypeCheck Val
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Bool, Val) -> Val
forall a b. (a, b) -> b
snd (TypeCheck (Bool, Val) -> TypeCheck Val)
-> TypeCheck (Bool, Val) -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val -> TypeCheck (Bool, Val)
force' Bool
False Val
v
appDef :: QName -> [Val] -> TypeCheck Val
appDef :: QName -> [Val] -> TypeCheck Val
appDef QName
n [Val]
vl =
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
case (Map.lookup n sig) of
Just (FunSig { isCo :: SigDef -> Co
isCo = Co
Ind, arity :: SigDef -> Arity
arity = Arity
ar, clauses :: SigDef -> [Clause]
clauses = [Clause]
cl, isTypeChecked :: SigDef -> Bool
isTypeChecked = Bool
True })
| [Val] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Val]
vl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity -> Int
fullArity Arity
ar -> do
m <- Env -> [Clause] -> [Val] -> TypeCheck (Maybe Val)
matchClauses Env
forall a. Environ a
emptyEnv [Clause]
cl [Val]
vl
case m of
Maybe Val
Nothing -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> [Val] -> Val
VApp (DefId -> Val
VDef (IdKind -> QName -> DefId
DefId IdKind
FunK QName
n)) [Val]
vl
Just Val
v2 -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v2
Maybe SigDef
_ -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> [Val] -> Val
VApp (DefId -> Val
VDef (IdKind -> QName -> DefId
DefId IdKind
FunK QName
n)) [Val]
vl
up :: Bool -> Val -> TVal -> TypeCheck Val
up :: Bool -> Val -> Val -> TypeCheck Val
up Bool
f (VUp Val
v Val
tv') Val
tv = Bool -> Val -> Val -> TypeCheck Val
up Bool
f Val
v Val
tv
up Bool
f Val
v tv :: Val
tv@VQuant{ vqPiSig :: Val -> PiSigma
vqPiSig = PiSigma
Pi } = Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Val
VUp Val
v Val
tv
up Bool
f Val
_ (VSing Val
v Val
vt) = Bool -> Val -> Val -> TypeCheck Val
up Bool
f Val
v Val
vt
up Bool
f Val
v (VDef DefId
d) = Val -> TypeCheck Val
forall (m :: * -> *) a. MonadError TraceError m => Val -> m a
failValInv (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ DefId -> Val
VDef DefId
d
up Bool
f Val
v (VApp (VDef (DefId IdKind
DatK QName
d)) [Val]
vl) = Bool -> Val -> QName -> [Val] -> TypeCheck Val
upData Bool
f Val
v QName
d [Val]
vl
up Bool
f Val
v Val
_ = Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v
matchingConstructors :: Val -> TypeCheck (Maybe [(ConstructorInfo,Env)])
matchingConstructors :: Val -> TypeCheck (Maybe [(ConstructorInfo, Env)])
matchingConstructors v :: Val
v@(VDef DefId
d) = Val -> TypeCheck (Maybe [(ConstructorInfo, Env)])
forall (m :: * -> *) a. MonadError TraceError m => Val -> m a
failValInv Val
v
matchingConstructors (VApp (VDef (DefId IdKind
DatK QName
d)) [Val]
vl) = QName -> [Val] -> TypeCheck [(ConstructorInfo, Env)]
matchingConstructors' QName
d [Val]
vl TypeCheck [(ConstructorInfo, Env)]
-> ([(ConstructorInfo, Env)]
-> TypeCheck (Maybe [(ConstructorInfo, Env)]))
-> TypeCheck (Maybe [(ConstructorInfo, Env)])
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
>>= Maybe [(ConstructorInfo, Env)]
-> TypeCheck (Maybe [(ConstructorInfo, Env)])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(ConstructorInfo, Env)]
-> TypeCheck (Maybe [(ConstructorInfo, Env)]))
-> ([(ConstructorInfo, Env)] -> Maybe [(ConstructorInfo, Env)])
-> [(ConstructorInfo, Env)]
-> TypeCheck (Maybe [(ConstructorInfo, Env)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ConstructorInfo, Env)] -> Maybe [(ConstructorInfo, Env)]
forall a. a -> Maybe a
Just
matchingConstructors Val
v = Maybe [(ConstructorInfo, Env)]
-> TypeCheck (Maybe [(ConstructorInfo, Env)])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(ConstructorInfo, Env)]
forall a. Maybe a
Nothing
matchingConstructors' :: QName -> [Val] -> TypeCheck [(ConstructorInfo,Env)]
matchingConstructors' :: QName -> [Val] -> TypeCheck [(ConstructorInfo, Env)]
matchingConstructors' QName
n [Val]
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 {symbTyp :: SigDef -> Val
symbTyp = Val
dv, constructors :: SigDef -> [ConstructorInfo]
constructors = [ConstructorInfo]
cs}) ->
Bool
-> [Val]
-> Val
-> [ConstructorInfo]
-> TypeCheck [(ConstructorInfo, Env)]
matchingConstructors'' Bool
True [Val]
vl Val
dv [ConstructorInfo]
cs
matchingConstructors'' :: Bool -> [Val] -> Val -> [ConstructorInfo] -> TypeCheck [(ConstructorInfo,Env)]
matchingConstructors'' :: Bool
-> [Val]
-> Val
-> [ConstructorInfo]
-> TypeCheck [(ConstructorInfo, Env)]
matchingConstructors'' Bool
symm [Val]
vl Val
dv [ConstructorInfo]
cs = do
vl <- (Val -> TypeCheck Val)
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Val]
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 Val -> TypeCheck Val
whnfClos [Val]
vl
compressMaybes <$> do
forM cs $ \ ConstructorInfo
ci -> do
let ps :: [Pattern]
ps = (PatternsType, [Pattern]) -> [Pattern]
forall a b. (a, b) -> b
snd (ConstructorInfo -> (PatternsType, [Pattern])
cPatFam ConstructorInfo
ci)
(Env -> (ConstructorInfo, Env))
-> Maybe Env -> Maybe (ConstructorInfo, Env)
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 (ConstructorInfo, Env))
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe (ConstructorInfo, Env))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Env
-> [Pattern]
-> [Val]
-> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
nonLinMatchList Bool
symm Env
forall a. Environ a
emptyEnv [Pattern]
ps [Val]
vl Val
dv
data MatchingConstructors a
= NoConstructor
| OneConstructor a
| ManyConstructors
| UnknownConstructors
deriving (MatchingConstructors a -> MatchingConstructors a -> Bool
(MatchingConstructors a -> MatchingConstructors a -> Bool)
-> (MatchingConstructors a -> MatchingConstructors a -> Bool)
-> Eq (MatchingConstructors a)
forall a.
Eq a =>
MatchingConstructors a -> MatchingConstructors a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
MatchingConstructors a -> MatchingConstructors a -> Bool
== :: MatchingConstructors a -> MatchingConstructors a -> Bool
$c/= :: forall a.
Eq a =>
MatchingConstructors a -> MatchingConstructors a -> Bool
/= :: MatchingConstructors a -> MatchingConstructors a -> Bool
Eq,Int -> MatchingConstructors a -> String -> String
[MatchingConstructors a] -> String -> String
MatchingConstructors a -> String
(Int -> MatchingConstructors a -> String -> String)
-> (MatchingConstructors a -> String)
-> ([MatchingConstructors a] -> String -> String)
-> Show (MatchingConstructors a)
forall a.
Show a =>
Int -> MatchingConstructors a -> String -> String
forall a. Show a => [MatchingConstructors a] -> String -> String
forall a. Show a => MatchingConstructors a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a.
Show a =>
Int -> MatchingConstructors a -> String -> String
showsPrec :: Int -> MatchingConstructors a -> String -> String
$cshow :: forall a. Show a => MatchingConstructors a -> String
show :: MatchingConstructors a -> String
$cshowList :: forall a. Show a => [MatchingConstructors a] -> String -> String
showList :: [MatchingConstructors a] -> String -> String
Show)
getMatchingConstructor
:: Bool
-> QName
-> [Val]
-> TypeCheck (MatchingConstructors
( Co
, [Val]
, Env
, [Val]
, ConstructorInfo
))
getMatchingConstructor :: Bool
-> QName
-> [Val]
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
getMatchingConstructor Bool
eta QName
n [Val]
vl = String
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a. String -> a -> a
traceRecord (String
"getMatchingConstructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (QName, [Val]) -> String
forall a. Show a => a -> String
show (QName
n, [Val]
vl)) (TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a b. (a -> b) -> a -> b
$
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
case Map.lookup n sig of
Just (DataSig {symbTyp :: SigDef -> Val
symbTyp = Val
dv, numPars :: SigDef -> Int
numPars = Int
npars, isCo :: SigDef -> Co
isCo = Co
co, constructors :: SigDef -> [ConstructorInfo]
constructors = [ConstructorInfo]
cs, Bool
etaExpand :: Bool
etaExpand :: SigDef -> Bool
etaExpand}) | Bool
eta Bool -> Bool -> Bool
`implies` Bool
etaExpand ->
if ([ConstructorInfo] -> Bool
forall a. Null a => a -> Bool
null [ConstructorInfo]
cs) then MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
forall a. MatchingConstructors a
NoConstructor else do
cenvs <- Bool
-> [Val]
-> Val
-> [ConstructorInfo]
-> TypeCheck [(ConstructorInfo, Env)]
matchingConstructors'' Bool
False [Val]
vl Val
dv [ConstructorInfo]
cs
traceRecordM $ "Matching constructors: " ++ show cenvs
case cenvs of
[(ConstructorInfo
ci,Env
env)] -> if Bool
eta Bool -> Bool -> Bool
&& Bool -> Bool
not (ConstructorInfo -> Bool
cEtaExp ConstructorInfo
ci) then MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
forall a. MatchingConstructors a
UnknownConstructors else do
let fis :: [FieldInfo]
fis = ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci
let indices :: [FieldInfo]
indices = (FieldInfo -> Bool) -> [FieldInfo] -> [FieldInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ FieldInfo
fi -> FieldInfo -> FieldClass
fClass FieldInfo
fi FieldClass -> FieldClass -> Bool
forall a. Eq a => a -> a -> Bool
== FieldClass
Index) [FieldInfo]
fis
let indvs :: [Val]
indvs = (FieldInfo -> Val) -> [FieldInfo] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (\ FieldInfo
fi -> Env -> Name -> Val
forall a. Show a => Environ a -> Name -> a
lookupPure Env
env (FieldInfo -> Name
fName FieldInfo
fi)) [FieldInfo]
indices
let ([Val]
pars, [Val]
_) = Int -> [Val] -> ([Val], [Val])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
npars [Val]
vl
MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)))
-> MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a b. (a -> b) -> a -> b
$ (Co, [Val], Env, [Val], ConstructorInfo)
-> MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
forall a. a -> MatchingConstructors a
OneConstructor (Co
co, [Val]
pars, Env
env, [Val]
indvs, ConstructorInfo
ci)
[(ConstructorInfo, Env)]
l ->
MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
forall a. MatchingConstructors a
ManyConstructors
Maybe SigDef
_ -> String
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a. String -> a -> a
traceRecord (String
"no eta expandable type") (TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a b. (a -> b) -> a -> b
$ MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
forall a. MatchingConstructors a
UnknownConstructors
getFieldsAtType
:: QName
-> [Val]
-> TypeCheck
(Maybe
[(Name
,TVal)])
getFieldsAtType :: QName -> [Val] -> TypeCheck (Maybe [(Name, Val)])
getFieldsAtType QName
n [Val]
vl = do
mc <- Bool
-> QName
-> [Val]
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
getMatchingConstructor Bool
False QName
n [Val]
vl
case mc of
OneConstructor (Co
_, [Val]
pars, Env
_, [Val]
indvs, ConstructorInfo
ci) -> do
let pi :: [Val]
pi = [Val]
pars [Val] -> [Val] -> [Val]
forall a. [a] -> [a] -> [a]
++ [Val]
indvs
let arg :: FieldInfo
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
arg (FieldInfo { fName :: FieldInfo -> Name
fName = Name
x, fClass :: FieldInfo -> FieldClass
fClass = FieldClass
Index }) = [(Name, Val)]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
arg (FieldInfo { fName :: FieldInfo -> Name
fName = Name
d, fClass :: FieldInfo -> FieldClass
fClass = Field Maybe Destructor
_ }) = do
t <- Name -> TypeCheck Val
forall (m :: * -> *). MonadSig m => Name -> m Val
lookupSymbTyp Name
d
t' <- piApps t pi
return [(d,t')]
[(Name, Val)] -> Maybe [(Name, Val)]
forall a. a -> Maybe a
Just ([(Name, Val)] -> Maybe [(Name, Val)])
-> ([[(Name, Val)]] -> [(Name, Val)])
-> [[(Name, Val)]]
-> Maybe [(Name, Val)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Name, Val)]] -> [(Name, Val)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, Val)]] -> Maybe [(Name, Val)])
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [[(Name, Val)]]
-> TypeCheck (Maybe [(Name, Val)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldInfo
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)])
-> [FieldInfo]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [[(Name, Val)]]
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 FieldInfo
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [(Name, Val)]
arg (ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci)
MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
_ -> Maybe [(Name, Val)] -> TypeCheck (Maybe [(Name, Val)])
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(Name, Val)]
forall a. Maybe a
Nothing
projectType :: TVal -> Name -> Val -> TypeCheck TVal
projectType :: Val -> Name -> Val -> TypeCheck Val
projectType Val
tv Name
p Val
rv = 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 record type when taking the projection" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Expr
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (PrePost -> Name -> Expr
Proj PrePost
Post 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
P.<> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall (m :: * -> *). Monad m => m Doc
comma 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
"but found 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
tv)
let fail2 :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
fail2 = 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
"record 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
"does not have field" StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Name
p)
case Val
tv of
VApp (VDef (DefId IdKind
DatK QName
d)) [Val]
vl -> do
mfs <- QName -> [Val] -> TypeCheck (Maybe [(Name, Val)])
getFieldsAtType QName
d [Val]
vl
case mfs of
Maybe [(Name, Val)]
Nothing -> TypeCheck Val
forall {a}.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
fail1
Just [(Name, Val)]
ptvs ->
case Name -> [(Name, Val)] -> Maybe Val
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
p [(Name, Val)]
ptvs of
Maybe Val
Nothing -> TypeCheck Val
forall {a}.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
fail2
Just Val
tv -> Val -> Val -> TypeCheck Val
piApp Val
tv Val
rv
Val
_ -> TypeCheck Val
forall {a}.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
fail1
upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val
upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val
upData Bool
force Val
v QName
n [Val]
vl =
do
let ret :: a -> m a
ret a
v' = String -> m a -> m a
forall a. String -> a -> a
traceEta (String
"Eta-expanding: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at 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]
++ [Val] -> String
forall a. Show a => a -> String
show [Val]
vl) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v'
mc <- Bool
-> QName
-> [Val]
-> TypeCheck
(MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo))
getMatchingConstructor Bool
True QName
n [Val]
vl
case mc of
MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
NoConstructor -> Val -> TypeCheck Val
forall {a} {m :: * -> *}. (Show a, Monad m) => a -> m a
ret Val
VIrr
OneConstructor (Co
co, [Val]
pars, Env
env, [Val]
indvs, ConstructorInfo
ci) ->
if (Co
coCo -> Co -> Bool
forall a. Eq a => a -> a -> Bool
==Co
CoInd Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
force) then Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Val
VUp Val
v (Val -> [Val] -> Val
VApp (DefId -> Val
VDef (DefId -> Val) -> DefId -> Val
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
DatK QName
n) [Val]
vl) else do
let fis :: [FieldInfo]
fis = ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci
let piv :: [Val]
piv = [Val]
pars [Val] -> [Val] -> [Val]
forall a. [a] -> [a] -> [a]
++ [Val]
indvs [Val] -> [Val] -> [Val]
forall a. [a] -> [a] -> [a]
++ [Val
v]
let arg :: FieldInfo -> TypeCheck Val
arg (FieldInfo { fName :: FieldInfo -> Name
fName = Name
x, fClass :: FieldInfo -> FieldClass
fClass = FieldClass
Index }) =
Env -> Name -> TypeCheck Val
forall (m :: * -> *) a.
MonadError TraceError m =>
Environ a -> Name -> m a
lookupEnv Env
env Name
x
arg (FieldInfo { fName :: FieldInfo -> Name
fName = Name
d, fClass :: FieldInfo -> FieldClass
fClass = Field Maybe Destructor
_ }) = do
LetSig {symbTyp = t, definingVal = w} <- Name
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => Name -> m SigDef
lookupSymb Name
d
t' <- piApps t piv
w <- app' False v (VProj Post d)
up False w t'
vs <- (FieldInfo -> TypeCheck Val)
-> [FieldInfo]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Val]
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 FieldInfo -> TypeCheck Val
arg [FieldInfo]
fis
let fs = (FieldInfo -> Name) -> [FieldInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldInfo -> Name
fName [FieldInfo]
fis
v' = RecInfo -> [(Name, Val)] -> Val
VRecord (ConK -> QName -> Bool -> Dotted -> RecInfo
NamedRec (Co -> ConK
coToConK Co
co) (ConstructorInfo -> QName
cName ConstructorInfo
ci) Bool
False Dotted
notDotted) ([(Name, Val)] -> Val) -> [(Name, Val)] -> Val
forall a b. (a -> b) -> a -> b
$ [Name] -> [Val] -> [(Name, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fs [Val]
vs
ret v'
MatchingConstructors (Co, [Val], Env, [Val], ConstructorInfo)
_ -> Val -> TypeCheck Val
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v
matchClauses :: Env -> [Clause] -> [Val] -> TypeCheck (Maybe Val)
matchClauses :: Env -> [Clause] -> [Val] -> TypeCheck (Maybe Val)
matchClauses Env
env [Clause]
cl [Val]
vl0 = do
vl <- (Val -> TypeCheck Val)
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) [Val]
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 Val -> TypeCheck Val
reduce [Val]
vl0
loop cl vl
where loop :: [Clause] -> [Val] -> TypeCheck (Maybe Val)
loop [] [Val]
vl = Maybe Val -> TypeCheck (Maybe Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Val
forall a. Maybe a
Nothing
loop (Clause TeleVal
_ [Pattern]
pl Maybe Expr
Nothing : [Clause]
cl2) [Val]
vl = [Clause] -> [Val] -> TypeCheck (Maybe Val)
loop [Clause]
cl2 [Val]
vl
loop (Clause TeleVal
_ [Pattern]
pl (Just Expr
rhs) : [Clause]
cl2) [Val]
vl =
do x <- Env -> [Pattern] -> Expr -> [Val] -> TypeCheck (Maybe Val)
matchClause Env
env [Pattern]
pl Expr
rhs [Val]
vl
case x of
Maybe Val
Nothing -> [Clause] -> [Val] -> TypeCheck (Maybe Val)
loop [Clause]
cl2 [Val]
vl
Just Val
v -> Maybe Val -> TypeCheck (Maybe Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Val -> TypeCheck (Maybe Val))
-> Maybe Val -> TypeCheck (Maybe Val)
forall a b. (a -> b) -> a -> b
$ Val -> Maybe Val
forall a. a -> Maybe a
Just Val
v
bindMaybe :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
bindMaybe :: forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
bindMaybe m (Maybe a)
mma a -> m (Maybe b)
k = m (Maybe a)
mma m (Maybe a) -> (Maybe a -> m (Maybe b)) -> m (Maybe b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe b) -> (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe b -> m (Maybe b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing) a -> m (Maybe b)
k
matchClause :: Env -> [Pattern] -> Expr -> [Val] -> TypeCheck (Maybe Val)
matchClause :: Env -> [Pattern] -> Expr -> [Val] -> TypeCheck (Maybe Val)
matchClause Env
env [Pattern]
pl Expr
rhs [Val]
vl =
case ([Pattern]
pl, [Val]
vl) of
(Pattern
p:[Pattern]
pl, Val
v:[Val]
vl) -> Env
-> Pattern
-> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
match Env
env Pattern
p Val
v StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
-> (Env -> TypeCheck (Maybe Val)) -> TypeCheck (Maybe Val)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
`bindMaybe` \ Env
env' -> Env -> [Pattern] -> Expr -> [Val] -> TypeCheck (Maybe Val)
matchClause Env
env' [Pattern]
pl Expr
rhs [Val]
vl
([], [Val]
_) -> Val -> Maybe Val
forall a. a -> Maybe a
Just (Val -> Maybe Val) -> TypeCheck Val -> TypeCheck (Maybe Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do (Val -> [Val] -> TypeCheck Val) -> [Val] -> Val -> TypeCheck Val
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Val -> Val -> TypeCheck Val) -> Val -> [Val] -> TypeCheck Val
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Val -> Val -> TypeCheck Val
app) [Val]
vl (Val -> TypeCheck Val) -> TypeCheck Val -> TypeCheck Val
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Expr -> TypeCheck Val
whnf Env
env Expr
rhs
([Pattern]
_, []) -> Maybe Val -> TypeCheck (Maybe Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Val
forall a. Maybe a
Nothing
match :: Env -> Pattern -> Val -> TypeCheck (Maybe Env)
match :: Env
-> Pattern
-> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
match Env
env Pattern
p Val
v0 =
do
v <- case Pattern
p of
ConP{} -> do v <- Val -> TypeCheck Val
force Val
v0; traceMatch ("matching pattern " ++ show (p,v)) $ return v
PairP{} -> do v <- Val -> TypeCheck Val
force Val
v0; traceMatch ("matching pattern " ++ show (p,v)) $ return v
Pattern
_ -> Val -> TypeCheck Val
whnfClos Val
v0
case (p,v) of
(ErasedP Pattern
p,Val
_) -> Env
-> Pattern
-> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
match Env
env Pattern
p Val
v
(AbsurdP{},Val
_) -> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Maybe Env
forall a. a -> Maybe a
Just Env
env
(DotP Expr
_, Val
_) -> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Maybe Env
forall a. a -> Maybe a
Just Env
env
(VarP Name
x, Val
_) -> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Maybe Env
forall a. a -> Maybe a
Just (Env -> Name -> Val -> Env
forall a. Environ a -> Name -> a -> Environ a
update Env
env Name
x Val
v)
(SizeP Expr
_ Name
x,Val
_) -> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Maybe Env
forall a. a -> Maybe a
Just (Env -> Name -> Val -> Env
forall a. Environ a -> Name -> a -> Environ a
update Env
env Name
x Val
v)
(ProjP Name
x, VProj PrePost
Post Name
y) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y -> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Maybe Env
forall a. a -> Maybe a
Just Env
env
(PairP Pattern
p1 Pattern
p2, VPair Val
v1 Val
v2) -> Env
-> [Pattern]
-> [Val]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
matchList Env
env [Pattern
p1,Pattern
p2] [Val
v1,Val
v2]
(ConP PatternInfo
_ QName
x [],VDef (DefId (ConK ConK
_) QName
y)) -> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall (m :: * -> *) a. MonadError TraceError m => Val -> m a
failValInv Val
v
(ConP PatternInfo
_ QName
x [Pattern]
pl,VApp (VDef (DefId (ConK ConK
_) QName
y)) [Val]
vl) | QName -> QName -> Bool
nameInstanceOf QName
x QName
y -> Env
-> [Pattern]
-> [Val]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
matchList Env
env [Pattern]
pl [Val]
vl
(ConP PatternInfo
_ QName
x [Pattern]
pl,VRecord (NamedRec ConK
ri QName
y Bool
_ Dotted
dotted) [(Name, Val)]
rs) | QName -> QName -> Bool
nameInstanceOf QName
x QName
y Bool -> Bool -> Bool
&& Bool -> Bool
not (Dotted -> Bool
isDotted Dotted
dotted) ->
Env
-> [Pattern]
-> [Val]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
matchList Env
env [Pattern]
pl ([Val]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> [Val]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ ((Name, Val) -> Val) -> [(Name, Val)] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Val) -> Val
forall a b. (a, b) -> b
snd [(Name, Val)]
rs
(p :: Pattern
p@(ConP PatternInfo
pi QName
_ [Pattern]
_), Val
v) | PatternInfo -> ConK
coPat PatternInfo
pi ConK -> ConK -> Bool
forall a. Eq a => a -> a -> Bool
== ConK
DefPat -> do
p <- Pattern -> TypeCheck Pattern
expandDefPat Pattern
p
match env p v
(SuccP Pattern
p', Val
v) -> (Val -> Maybe Val
predSize (Val -> Maybe Val) -> TypeCheck Val -> TypeCheck (Maybe Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Val
whnfClos Val
v) TypeCheck (Maybe Val)
-> (Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
`bindMaybe` Env
-> Pattern
-> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
match Env
env Pattern
p'
(UnusableP Pattern
p,Val
_) -> String
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
"internal error: match " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Pattern, Val) -> String
forall a. Show a => a -> String
show (Pattern
p,Val
v))
(Pattern, Val)
_ -> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Env
forall a. Maybe a
Nothing
matchList :: Env -> [Pattern] -> [Val] -> TypeCheck (Maybe Env)
matchList :: Env
-> [Pattern]
-> [Val]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
matchList Env
env [] [] = Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> Maybe Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Maybe Env
forall a. a -> Maybe a
Just Env
env
matchList Env
env (Pattern
p:[Pattern]
pl) (Val
v:[Val]
vl) =
Env
-> Pattern
-> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
match Env
env Pattern
p Val
v StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
-> (Env
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
`bindMaybe` \ Env
env' ->
Env
-> [Pattern]
-> [Val]
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
matchList Env
env' [Pattern]
pl [Val]
vl
matchList Env
env [Pattern]
pl [Val]
vl = String
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env))
-> String
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall a b. (a -> b) -> a -> b
$ String
"matchList internal error: inequal length while trying to match patterns " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Pattern] -> String
forall a. Show a => a -> String
show [Pattern]
pl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" against values " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Val] -> String
forall a. Show a => a -> String
show [Val]
vl
type GenToPattern = [(Int,Pattern)]
type MatchState = (Env, GenToPattern)
nonLinMatch :: Bool -> Bool -> MatchState -> Pattern -> Val -> TVal -> TypeCheck (Maybe MatchState)
nonLinMatch :: Bool
-> Bool
-> MatchState
-> Pattern
-> Val
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatch Bool
undot Bool
symm MatchState
st Pattern
p Val
v0 Val
tv = String
-> TypeCheck (Maybe MatchState) -> TypeCheck (Maybe MatchState)
forall a. String -> a -> a
traceMatch (String
"matching pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Pattern, Val) -> String
forall a. Show a => a -> String
show (Pattern
p,Val
v0)) (TypeCheck (Maybe MatchState) -> TypeCheck (Maybe MatchState))
-> TypeCheck (Maybe MatchState) -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ do
v <- case Pattern
p of
ConP{} -> Val -> TypeCheck Val
force Val
v0
PairP{} -> Val -> TypeCheck Val
force Val
v0
Pattern
_ -> Val -> TypeCheck Val
whnfClos Val
v0
case (p,v) of
(ErasedP{}, Val
_) -> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just MatchState
st
(DotP{} , Val
_) -> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just MatchState
st
(Pattern
_, VGen Int
i) | Bool
symm -> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just (MatchState -> Maybe MatchState) -> MatchState -> Maybe MatchState
forall a b. (a -> b) -> a -> b
$ ([(Int, Pattern)] -> [(Int, Pattern)]) -> MatchState -> MatchState
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd ((Int
i,Pattern
p)(Int, Pattern) -> [(Int, Pattern)] -> [(Int, Pattern)]
forall a. a -> [a] -> [a]
:) MatchState
st
(VarP Name
x, Val
_) -> Name -> Val -> TypeCheck (Maybe MatchState)
matchVarP Name
x Val
v
(SizeP Expr
_ Name
x, Val
_) -> Name -> Val -> TypeCheck (Maybe MatchState)
matchVarP Name
x Val
v
(ProjP Name
x, VProj PrePost
Post Name
y) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y -> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just MatchState
st
(ConP PatternInfo
_ QName
c [Pattern]
pl, VApp (VDef (DefId (ConK ConK
_) QName
c')) [Val]
vl) | QName -> QName -> Bool
nameInstanceOf QName
c QName
c' -> do
vc <- QName -> Val -> TypeCheck Val
conLType QName
c Val
tv
nonLinMatchList' undot symm st pl vl vc
(ConP PatternInfo
_ QName
c [Pattern]
pl, VRecord (NamedRec ConK
_ QName
c' Bool
_ Dotted
dotted) [(Name, Val)]
rs) | QName -> QName -> Bool
nameInstanceOf QName
c QName
c' -> do
Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
undot (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
$ Dotted
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadIO m => Dotted -> m ()
clearDotted Dotted
dotted
vc <- QName -> Val -> TypeCheck Val
conLType QName
c Val
tv
nonLinMatchList' undot symm st pl (map snd rs) vc
(Pattern
_, VRecord (NamedRec ConK
_ QName
c' Bool
_ Dotted
dotted) [(Name, Val)]
rs) | Dotted -> Bool
isDotted Dotted
dotted Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
undot -> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just MatchState
st
(p :: Pattern
p@(ConP PatternInfo
pi QName
_ [Pattern]
_), Val
v) | PatternInfo -> ConK
coPat PatternInfo
pi ConK -> ConK -> Bool
forall a. Eq a => a -> a -> Bool
== ConK
DefPat -> do
p <- Pattern -> TypeCheck Pattern
expandDefPat Pattern
p
nonLinMatch undot symm st p v tv
(PairP Pattern
p1 Pattern
p2, VPair Val
v1 Val
v2) -> do
tv <- Val -> TypeCheck Val
force Val
tv
case tv of
VQuant PiSigma
Sigma Name
x Domain
dom Val
fv -> do
Bool
-> Bool
-> MatchState
-> Pattern
-> Val
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatch Bool
undot Bool
symm MatchState
st Pattern
p1 Val
v1 (Domain -> Val
forall a. Dom a -> a
typ Domain
dom) TypeCheck (Maybe MatchState)
-> (MatchState -> TypeCheck (Maybe MatchState))
-> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
`bindMaybe` \ MatchState
st -> do
Bool
-> Bool
-> MatchState
-> Pattern
-> Val
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatch Bool
undot Bool
symm MatchState
st Pattern
p2 Val
v2 (Val -> TypeCheck (Maybe MatchState))
-> TypeCheck Val -> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> Val -> TypeCheck Val
app Val
fv Val
v1
Val
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (Maybe MatchState))
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (Maybe MatchState)
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
"nonLinMatch: 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
"to be a Sigma-type (&)"
(SuccP Pattern
p', Val
v) -> (Val -> Maybe Val
predSize (Val -> Maybe Val) -> TypeCheck Val -> TypeCheck (Maybe Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> TypeCheck Val
whnfClos Val
v) TypeCheck (Maybe Val)
-> (Val -> TypeCheck (Maybe MatchState))
-> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
`bindMaybe` \ Val
v' ->
Bool
-> Bool
-> MatchState
-> Pattern
-> Val
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatch Bool
undot Bool
symm MatchState
st Pattern
p' Val
v' Val
tv
(Pattern, Val)
_ -> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MatchState
forall a. Maybe a
Nothing
where
matchVarP :: Name -> Val -> TypeCheck (Maybe MatchState)
matchVarP Name
x Val
v = do
let env :: Env
env = MatchState -> Env
forall a b. (a, b) -> a
fst MatchState
st
case ((Name, Val) -> Bool) -> [(Name, Val)] -> Maybe (Name, Val)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) (Name -> Bool) -> ((Name, Val) -> Name) -> (Name, Val) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Val) -> Name
forall a b. (a, b) -> a
fst) ([(Name, Val)] -> Maybe (Name, Val))
-> [(Name, Val)] -> Maybe (Name, Val)
forall a b. (a -> b) -> a -> b
$ Env -> [(Name, Val)]
forall a. Environ a -> [(Name, a)]
envMap (Env -> [(Name, Val)]) -> Env -> [(Name, Val)]
forall a b. (a -> b) -> a -> b
$ MatchState -> Env
forall a b. (a, b) -> a
fst MatchState
st of
Maybe (Name, Val)
Nothing -> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just (MatchState -> Maybe MatchState) -> MatchState -> Maybe MatchState
forall a b. (a -> b) -> a -> b
$ (Env -> Env) -> MatchState -> MatchState
forall a c d. (a -> c) -> (a, d) -> (c, d)
mapFst (\ Env
env -> Env -> Name -> Val -> Env
forall a. Environ a -> Name -> a -> Environ a
update Env
env Name
x Val
v) MatchState
st
Just (Name
y,Val
v') -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> TypeCheck (Maybe MatchState)
-> TypeCheck (Maybe MatchState)
-> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Val
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
eqValBool Val
tv Val
v Val
v') (Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just MatchState
st) (Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MatchState
forall a. Maybe a
Nothing)
nonLinMatchList :: Bool -> Env -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe Env)
nonLinMatchList :: Bool
-> Env
-> [Pattern]
-> [Val]
-> Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
nonLinMatchList Bool
symm Env
env [Pattern]
ps [Val]
vs Val
tv =
(MatchState -> Env) -> Maybe MatchState -> Maybe Env
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MatchState -> Env
forall a b. (a, b) -> a
fst (Maybe MatchState -> Maybe Env)
-> TypeCheck (Maybe MatchState)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Env)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Bool
-> MatchState
-> [Pattern]
-> [Val]
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatchList' Bool
False Bool
symm (Env
env, []) [Pattern]
ps [Val]
vs Val
tv
nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState)
nonLinMatchList' :: Bool
-> Bool
-> MatchState
-> [Pattern]
-> [Val]
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatchList' Bool
undot Bool
symm MatchState
st [] [] Val
tv = Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MatchState -> TypeCheck (Maybe MatchState))
-> Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ MatchState -> Maybe MatchState
forall a. a -> Maybe a
Just MatchState
st
nonLinMatchList' Bool
undot Bool
symm MatchState
st (Pattern
p:[Pattern]
pl) (Val
v:[Val]
vl) Val
tv = do
tv <- Val -> TypeCheck Val
force Val
tv
case tv of
VQuant PiSigma
Pi Name
x Domain
dom Val
fv ->
Bool
-> Bool
-> MatchState
-> Pattern
-> Val
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatch Bool
undot Bool
symm MatchState
st Pattern
p Val
v (Domain -> Val
forall a. Dom a -> a
typ Domain
dom) TypeCheck (Maybe MatchState)
-> (MatchState -> TypeCheck (Maybe MatchState))
-> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
`bindMaybe` \ MatchState
st' ->
Bool
-> Bool
-> MatchState
-> [Pattern]
-> [Val]
-> Val
-> TypeCheck (Maybe MatchState)
nonLinMatchList' Bool
undot Bool
symm MatchState
st' [Pattern]
pl [Val]
vl (Val -> TypeCheck (Maybe MatchState))
-> TypeCheck Val -> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> Val -> TypeCheck Val
app Val
fv Val
v
Val
_ -> String -> TypeCheck (Maybe MatchState)
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> TypeCheck (Maybe MatchState))
-> String -> TypeCheck (Maybe MatchState)
forall a b. (a -> b) -> a -> b
$ String
"nonLinMatchList': cannot match in absence of pi-type"
nonLinMatchList' Bool
_ Bool
_ MatchState
_ [Pattern]
_ [Val]
_ Val
_ = Maybe MatchState -> TypeCheck (Maybe MatchState)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MatchState
forall a. Maybe a
Nothing
expandDefPat :: Pattern -> TypeCheck Pattern
expandDefPat :: Pattern -> TypeCheck Pattern
expandDefPat p :: Pattern
p@(ConP PatternInfo
pi QName
c [Pattern]
ps) | PatternInfo -> ConK
coPat PatternInfo
pi ConK -> ConK -> Bool
forall a. Eq a => a -> a -> Bool
== ConK
DefPat = do
PatSig ns pat v <- QName
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => QName -> m SigDef
lookupSymbQ QName
c
unless (length ns == length ps) $
throwErrorMsg ("underapplied defined pattern in " ++ show p)
let pat' = if PatternInfo -> Bool
dottedPat PatternInfo
pi then Pattern -> Pattern
dotConstructors Pattern
pat else Pattern
pat
return $ patSubst (zip ns ps) pat'
expandDefPat Pattern
p = Pattern -> TypeCheck Pattern
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
p
#if MIN_VERSION_base(4,11,0)
instance Semigroup (TypeCheck Bool) where
<> :: 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
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
andLazy
instance Monoid (TypeCheck Bool) where
mempty :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
mempty = 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
mappend :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
mappend = 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. Semigroup a => a -> a -> a
(<>)
mconcat :: [StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
mconcat = [StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM
#else
instance Monoid (TypeCheck Bool) where
mempty = return True
mappend = andLazy
mconcat = andM
#endif
class Nocc a where
nocc :: [Int] -> a -> TypeCheck Bool
instance Nocc a => Nocc [a] where
nocc :: [Int]
-> [a]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc = (a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [a]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [a]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> ([Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [Int]
-> [a]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc
instance Nocc a => Nocc (Dom a) where
nocc :: [Int]
-> Dom a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc = (a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Dom a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall m a. Monoid m => (a -> m) -> Dom a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Dom a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> ([Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [Int]
-> Dom a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc
instance Nocc a => Nocc (Measure a) where
nocc :: [Int]
-> Measure a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc = (a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Measure a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall m a. Monoid m => (a -> m) -> Measure a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Measure a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> ([Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [Int]
-> Measure a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc
instance Nocc a => Nocc (Bound a) where
nocc :: [Int]
-> Bound a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc = (a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Bound a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall m a. Monoid m => (a -> m) -> Bound a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Bound a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> ([Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [Int]
-> Bound a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc
instance (Nocc a, Nocc b) => Nocc (a,b) where
nocc :: [Int]
-> (a, b)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks (a
a, b
b) = [Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks a
a 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 (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`andLazy` [Int]
-> b
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks b
b
instance Nocc a => Nocc (Sort a) where
nocc :: [Int]
-> Sort a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks (Set a
v) = [Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks a
v
nocc [Int]
ks (CoSet a
v) = [Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks a
v
nocc [Int]
ks (SortC Class
_) = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Monoid a => a
mempty
instance Nocc Val where
nocc :: [Int]
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Val
v = do
v <- Val -> TypeCheck Val
whnfClos Val
v
case v of
VGen Int
k -> 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
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ 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]
ks
VApp Val
v1 [Val]
vl -> [Int]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ Val
v1 Val -> [Val] -> [Val]
forall a. a -> [a] -> [a]
: [Val]
vl
VDef{} -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Monoid a => a
mempty
VProj{} -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Monoid a => a
mempty
VQuant PiSigma
pisig Name
x Domain
dom Val
fv -> [Int]
-> Domain
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Domain
dom 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. Monoid a => a -> a -> a
`mappend` do
Name
-> Domain
-> Val
-> (Int
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Name
-> Domain
-> Val
-> (Int -> Val -> Val -> TypeCheck a)
-> TypeCheck a
underAbs Name
x Domain
dom Val
fv ((Int
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Int
-> Val
-> Val
-> 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 Val
_xv Val
bv -> [Int]
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Val
bv
fv :: Val
fv@(VLam Name
x Env
env Expr
b) -> Name
-> Val
-> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Name -> Val -> (Val -> Val -> TypeCheck a) -> TypeCheck a
underAbs' Name
x Val
fv ((Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Val
_xv Val
bv -> [Int]
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Val
bv
fv :: Val
fv@(VAbs Name
x Int
i Val
u Valuation
valu) -> Name
-> Val
-> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Name -> Val -> (Val -> Val -> TypeCheck a) -> TypeCheck a
underAbs' Name
x Val
fv ((Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Val
_xv Val
bv -> [Int]
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Val
bv
fv :: Val
fv@(VConst Val
v) -> Name
-> Val
-> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Name -> Val -> (Val -> Val -> TypeCheck a) -> TypeCheck a
underAbs' Name
noName Val
fv ((Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ \ Val
_xv Val
bv -> [Int]
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Val
bv
VRecord RecInfo
_ [(Name, Val)]
rs -> [Int]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ ((Name, Val) -> Val) -> [(Name, Val)] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Val) -> Val
forall a b. (a, b) -> b
snd [(Name, Val)]
rs
VPair Val
v Val
w -> [Int]
-> (Val, Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks (Val
v, Val
w)
Val
VZero -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Monoid a => a
mempty
VSucc Val
v -> [Int]
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Val
v
Val
VInfty -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Monoid a => a
mempty
VMax [Val]
vl -> [Int]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks [Val]
vl
VPlus [Val]
vl -> [Int]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks [Val]
vl
VSort Sort Val
s -> [Int]
-> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Sort Val
s
VMeasured Measure Val
mu Val
tv -> [Int]
-> (Measure Val, Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks (Measure Val
mu, Val
tv)
VGuard Bound Val
beta Val
tv -> [Int]
-> (Bound Val, Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks (Bound Val
beta, Val
tv)
VBelow LtLe
ltle Val
v -> [Int]
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks Val
v
VSing Val
v Val
tv -> [Int]
-> (Val, Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks (Val
v, Val
tv)
VUp Val
v Val
tv -> [Int]
-> (Val, Val)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks (Val
v, Val
tv)
Val
VIrr -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a. Monoid a => a
mempty
VCase Val
v Val
tv Env
env [Clause]
cls -> [Int]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a.
Nocc a =>
[Int]
-> a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
nocc [Int]
ks ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ Val
v Val -> [Val] -> [Val]
forall a. a -> [a] -> [a]
: Val
tv Val -> [Val] -> [Val]
forall a. a -> [a] -> [a]
: ((Name, Val) -> Val) -> [(Name, Val)] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Val) -> Val
forall a b. (a, b) -> b
snd (Env -> [(Name, Val)]
forall a. Environ a -> [(Name, a)]
envMap Env
env)
VClos{} -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool)
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall a b. (a -> b) -> a -> b
$ String
"internal error: nocc " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Int], Val) -> String
forall a. Show a => a -> String
show ([Int]
ks,Val
v)
eqValBool :: TVal -> Val -> Val -> TypeCheck Bool
eqValBool :: Val
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
eqValBool Val
tv Val
v Val
v' = 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
$ Val
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
eqVal Val
tv Val
v Val
v'
eqVal :: TVal -> Val -> Val -> TypeCheck ()
eqVal :: Val
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
eqVal Val
tv = Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
N Pol
mixed (OneOrTwo Val -> MT12
forall a. a -> Maybe a
Just (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv))
data Force = N | L | R
deriving (Force -> Force -> Bool
(Force -> Force -> Bool) -> (Force -> Force -> Bool) -> Eq Force
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Force -> Force -> Bool
== :: Force -> Force -> Bool
$c/= :: Force -> Force -> Bool
/= :: Force -> Force -> Bool
Eq,Int -> Force -> String -> String
[Force] -> String -> String
Force -> String
(Int -> Force -> String -> String)
-> (Force -> String) -> ([Force] -> String -> String) -> Show Force
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Force -> String -> String
showsPrec :: Int -> Force -> String -> String
$cshow :: Force -> String
show :: Force -> String
$cshowList :: [Force] -> String -> String
showList :: [Force] -> String -> String
Show)
class Switchable a where
switch :: a -> a
instance Switchable Force where
switch :: Force -> Force
switch Force
L = Force
R
switch Force
R = Force
L
switch Force
N = Force
N
instance Switchable Pol where
switch :: Pol -> Pol
switch = Pol -> Pol
polNeg
instance Switchable (a,a) where
switch :: (a, a) -> (a, a)
switch (a
a,a
b) = (a
b,a
a)
instance Switchable a => Switchable (Maybe a) where
switch :: Maybe a -> Maybe a
switch = (a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Switchable a => a -> a
switch
leqDec :: Pol -> Dec -> Dec -> Bool
leqDec :: Pol -> Dec -> Dec -> Bool
leqDec Pol
p Dec
dec1 Dec
dec2 = Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec2
Bool -> Bool -> Bool
&& Pol -> (Pol -> Pol -> Bool) -> Pol -> Pol -> Bool
forall a. Pol -> (a -> a -> Bool) -> a -> a -> Bool
relPol Pol
p Pol -> Pol -> Bool
leqPol (Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec1) (Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec2)
subtype :: Val -> Val -> TypeCheck ()
subtype :: Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
subtype Val
v1 Val
v2 =
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
N Pol
Pos MT12
forall a. Maybe a
Nothing Val
v1 Val
v2
leqVal :: Pol -> TVal -> Val -> Val -> TypeCheck ()
leqVal :: Pol
-> Val
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal Pol
p Val
tv = Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
N Pol
p (OneOrTwo Val -> MT12
forall a. a -> Maybe a
Just (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv))
type MT12 = Maybe (OneOrTwo TVal)
data TypeShape
= ShQuant PiSigma
(OneOrTwo Name)
(OneOrTwo Domain)
(OneOrTwo FVal)
| ShSort SortShape
| ShData QName (OneOrTwo TVal)
| ShNe (OneOrTwo TVal)
| ShSing Val TVal
| ShSingL Val TVal TVal
| ShSingR TVal Val TVal
| ShNone
deriving (TypeShape -> TypeShape -> Bool
(TypeShape -> TypeShape -> Bool)
-> (TypeShape -> TypeShape -> Bool) -> Eq TypeShape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeShape -> TypeShape -> Bool
== :: TypeShape -> TypeShape -> Bool
$c/= :: TypeShape -> TypeShape -> Bool
/= :: TypeShape -> TypeShape -> Bool
Eq, Eq TypeShape
Eq TypeShape =>
(TypeShape -> TypeShape -> Ordering)
-> (TypeShape -> TypeShape -> Bool)
-> (TypeShape -> TypeShape -> Bool)
-> (TypeShape -> TypeShape -> Bool)
-> (TypeShape -> TypeShape -> Bool)
-> (TypeShape -> TypeShape -> TypeShape)
-> (TypeShape -> TypeShape -> TypeShape)
-> Ord TypeShape
TypeShape -> TypeShape -> Bool
TypeShape -> TypeShape -> Ordering
TypeShape -> TypeShape -> TypeShape
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TypeShape -> TypeShape -> Ordering
compare :: TypeShape -> TypeShape -> Ordering
$c< :: TypeShape -> TypeShape -> Bool
< :: TypeShape -> TypeShape -> Bool
$c<= :: TypeShape -> TypeShape -> Bool
<= :: TypeShape -> TypeShape -> Bool
$c> :: TypeShape -> TypeShape -> Bool
> :: TypeShape -> TypeShape -> Bool
$c>= :: TypeShape -> TypeShape -> Bool
>= :: TypeShape -> TypeShape -> Bool
$cmax :: TypeShape -> TypeShape -> TypeShape
max :: TypeShape -> TypeShape -> TypeShape
$cmin :: TypeShape -> TypeShape -> TypeShape
min :: TypeShape -> TypeShape -> TypeShape
Ord)
data SortShape
= ShSortC Class
| ShSet (OneOrTwo Val)
| ShCoSet (OneOrTwo Val)
deriving (SortShape -> SortShape -> Bool
(SortShape -> SortShape -> Bool)
-> (SortShape -> SortShape -> Bool) -> Eq SortShape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SortShape -> SortShape -> Bool
== :: SortShape -> SortShape -> Bool
$c/= :: SortShape -> SortShape -> Bool
/= :: SortShape -> SortShape -> Bool
Eq, Eq SortShape
Eq SortShape =>
(SortShape -> SortShape -> Ordering)
-> (SortShape -> SortShape -> Bool)
-> (SortShape -> SortShape -> Bool)
-> (SortShape -> SortShape -> Bool)
-> (SortShape -> SortShape -> Bool)
-> (SortShape -> SortShape -> SortShape)
-> (SortShape -> SortShape -> SortShape)
-> Ord SortShape
SortShape -> SortShape -> Bool
SortShape -> SortShape -> Ordering
SortShape -> SortShape -> SortShape
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SortShape -> SortShape -> Ordering
compare :: SortShape -> SortShape -> Ordering
$c< :: SortShape -> SortShape -> Bool
< :: SortShape -> SortShape -> Bool
$c<= :: SortShape -> SortShape -> Bool
<= :: SortShape -> SortShape -> Bool
$c> :: SortShape -> SortShape -> Bool
> :: SortShape -> SortShape -> Bool
$c>= :: SortShape -> SortShape -> Bool
>= :: SortShape -> SortShape -> Bool
$cmax :: SortShape -> SortShape -> SortShape
max :: SortShape -> SortShape -> SortShape
$cmin :: SortShape -> SortShape -> SortShape
min :: SortShape -> SortShape -> SortShape
Ord)
shSize :: TypeShape
shSize :: TypeShape
shSize = SortShape -> TypeShape
ShSort (Class -> SortShape
ShSortC Class
Size)
typeView :: TVal -> TypeShape
typeView :: Val -> TypeShape
typeView Val
tv =
case Val
tv of
VQuant PiSigma
pisig Name
x Domain
dom Val
fv -> PiSigma
-> OneOrTwo Name -> OneOrTwo Domain -> OneOrTwo Val -> TypeShape
ShQuant PiSigma
pisig (Name -> OneOrTwo Name
forall a. a -> OneOrTwo a
One Name
x) (Domain -> OneOrTwo Domain
forall a. a -> OneOrTwo a
One Domain
dom) (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
fv)
VBelow{} -> TypeShape
shSize
VSort Sort Val
s -> SortShape -> TypeShape
ShSort (Sort Val -> SortShape
sortView Sort Val
s)
VSing Val
v Val
tv -> Val -> Val -> TypeShape
ShSing Val
v Val
tv
VApp (VDef (DefId IdKind
DatK QName
n)) [Val]
vs -> QName -> OneOrTwo Val -> TypeShape
ShData QName
n (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)
VApp (VDef (DefId IdKind
FunK QName
n)) [Val]
vs -> OneOrTwo Val -> TypeShape
ShNe (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)
VApp (VGen Int
i) [Val]
vs -> OneOrTwo Val -> TypeShape
ShNe (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)
VGen Int
i -> OneOrTwo Val -> TypeShape
ShNe (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)
VCase{} -> OneOrTwo Val -> TypeShape
ShNe (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)
Val
_ -> TypeShape
ShNone
sortView :: Sort Val -> SortShape
sortView :: Sort Val -> SortShape
sortView Sort Val
s =
case Sort Val
s of
SortC Class
c -> Class -> SortShape
ShSortC Class
c
Set Val
v -> OneOrTwo Val -> SortShape
ShSet (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
v)
CoSet Val
v -> OneOrTwo Val -> SortShape
ShCoSet (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
v)
typeView12 :: (Functor m, Monad m, MonadError TraceError m) => OneOrTwo TVal -> m TypeShape
typeView12 :: forall (m :: * -> *).
(Functor m, Monad m, MonadError TraceError m) =>
OneOrTwo Val -> m TypeShape
typeView12 (One Val
tv) = TypeShape -> m TypeShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeShape -> m TypeShape) -> TypeShape -> m TypeShape
forall a b. (a -> b) -> a -> b
$ Val -> TypeShape
typeView Val
tv
typeView12 (Two Val
tv1 Val
tv2) =
case (Val
tv1, Val
tv2) of
(VQuant PiSigma
pisig1 Name
x1 Domain
dom1 Val
fv1, VQuant PiSigma
pisig2 Name
x2 Domain
dom2 Val
fv2)
| PiSigma
pisig1 PiSigma -> PiSigma -> Bool
forall a. Eq a => a -> a -> Bool
== PiSigma
pisig2 Bool -> Bool -> Bool
&& Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased (Domain -> Dec
forall a. Dom a -> Dec
decor Domain
dom1) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased (Domain -> Dec
forall a. Dom a -> Dec
decor Domain
dom2) ->
TypeShape -> m TypeShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeShape -> m TypeShape) -> TypeShape -> m TypeShape
forall a b. (a -> b) -> a -> b
$ PiSigma
-> OneOrTwo Name -> OneOrTwo Domain -> OneOrTwo Val -> TypeShape
ShQuant PiSigma
pisig1 (Name -> Name -> OneOrTwo Name
forall a. a -> a -> OneOrTwo a
Two Name
x1 Name
x2) (Domain -> Domain -> OneOrTwo Domain
forall a. a -> a -> OneOrTwo a
Two Domain
dom1 Domain
dom2) (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
fv1 Val
fv2)
(VSort Sort Val
s1, VSort Sort Val
s2) -> SortShape -> TypeShape
ShSort (SortShape -> TypeShape) -> m SortShape -> m TypeShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OneOrTwo (Sort Val) -> m SortShape
forall (m :: * -> *).
(Monad m, MonadError TraceError m) =>
OneOrTwo (Sort Val) -> m SortShape
sortView12 (Sort Val -> Sort Val -> OneOrTwo (Sort Val)
forall a. a -> a -> OneOrTwo a
Two Sort Val
s1 Sort Val
s2)
(VSing Val
v Val
tv, Val
_) -> TypeShape -> m TypeShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeShape -> m TypeShape) -> TypeShape -> m TypeShape
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Val -> TypeShape
ShSingL Val
v Val
tv Val
tv2
(Val
_, VSing Val
v Val
tv) -> TypeShape -> m TypeShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeShape -> m TypeShape) -> TypeShape -> m TypeShape
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Val -> TypeShape
ShSingR Val
tv1 Val
v Val
tv
(Val, Val)
_ -> case (Val -> TypeShape
typeView Val
tv1, Val -> TypeShape
typeView Val
tv2) of
(ShSort SortShape
s1, ShSort SortShape
s2) | SortShape
s1 SortShape -> SortShape -> Bool
forall a. Eq a => a -> a -> Bool
== SortShape
s2 -> TypeShape -> m TypeShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeShape -> m TypeShape) -> TypeShape -> m TypeShape
forall a b. (a -> b) -> a -> b
$ SortShape -> TypeShape
ShSort (SortShape -> TypeShape) -> SortShape -> TypeShape
forall a b. (a -> b) -> a -> b
$ SortShape
s1
(ShData QName
n1 OneOrTwo Val
_, ShData QName
n2 OneOrTwo Val
_) | QName
n1 QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
n2 -> TypeShape -> m TypeShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeShape -> m TypeShape) -> TypeShape -> m TypeShape
forall a b. (a -> b) -> a -> b
$ QName -> OneOrTwo Val -> TypeShape
ShData QName
n1 (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
tv1 Val
tv2)
(ShNe{} , ShNe{} ) -> TypeShape -> m TypeShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeShape -> m TypeShape) -> TypeShape -> m TypeShape
forall a b. (a -> b) -> a -> b
$ OneOrTwo Val -> TypeShape
ShNe (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
tv1 Val
tv2)
(TypeShape, TypeShape)
_ -> String -> m TypeShape
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> m TypeShape) -> String -> m TypeShape
forall a b. (a -> b) -> a -> b
$ String
"type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
tv1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has different shape than " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
tv2
sortView12 :: (Monad m, MonadError TraceError m) => OneOrTwo (Sort Val) -> m SortShape
sortView12 :: forall (m :: * -> *).
(Monad m, MonadError TraceError m) =>
OneOrTwo (Sort Val) -> m SortShape
sortView12 (One Sort Val
s) = SortShape -> m SortShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SortShape -> m SortShape) -> SortShape -> m SortShape
forall a b. (a -> b) -> a -> b
$ Sort Val -> SortShape
sortView Sort Val
s
sortView12 (Two Sort Val
s1 Sort Val
s2) =
case (Sort Val
s1, Sort Val
s2) of
(SortC Class
c1, SortC Class
c2) | Class
c1 Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
c2 -> SortShape -> m SortShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SortShape -> m SortShape) -> SortShape -> m SortShape
forall a b. (a -> b) -> a -> b
$ Class -> SortShape
ShSortC Class
c1
(Set Val
v1, Set Val
v2) -> SortShape -> m SortShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SortShape -> m SortShape) -> SortShape -> m SortShape
forall a b. (a -> b) -> a -> b
$ OneOrTwo Val -> SortShape
ShSet (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
v1 Val
v2)
(CoSet Val
v1, CoSet Val
v2) -> SortShape -> m SortShape
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SortShape -> m SortShape) -> SortShape -> m SortShape
forall a b. (a -> b) -> a -> b
$ OneOrTwo Val -> SortShape
ShCoSet (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
v1 Val
v2)
(Sort Val, Sort Val)
_ -> String -> m SortShape
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> m SortShape) -> String -> m SortShape
forall a b. (a -> b) -> a -> b
$ String
"sort " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sort Val -> String
forall a. Show a => a -> String
show Sort Val
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has different shape than " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sort Val -> String
forall a. Show a => a -> String
show Sort Val
s2
whnf12 :: OneOrTwo Env -> OneOrTwo Expr -> TypeCheck (OneOrTwo Val)
whnf12 :: OneOrTwo Env -> OneOrTwo Expr -> TypeCheck (OneOrTwo Val)
whnf12 OneOrTwo Env
env12 OneOrTwo Expr
e12 = (TypeCheck Val -> TypeCheck Val)
-> OneOrTwo (TypeCheck Val) -> TypeCheck (OneOrTwo Val)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OneOrTwo a -> f (OneOrTwo b)
traverse TypeCheck Val -> TypeCheck Val
forall a. a -> a
id (OneOrTwo (TypeCheck Val) -> TypeCheck (OneOrTwo Val))
-> OneOrTwo (TypeCheck Val) -> TypeCheck (OneOrTwo Val)
forall a b. (a -> b) -> a -> b
$ (Env -> Expr -> TypeCheck Val)
-> OneOrTwo Env -> OneOrTwo Expr -> OneOrTwo (TypeCheck Val)
forall a b c.
(a -> b -> c) -> OneOrTwo a -> OneOrTwo b -> OneOrTwo c
zipWith12 Env -> Expr -> TypeCheck Val
whnf OneOrTwo Env
env12 OneOrTwo Expr
e12
app12 :: OneOrTwo Val -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)
app12 :: OneOrTwo Val -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)
app12 OneOrTwo Val
fv12 OneOrTwo Val
v12 = (TypeCheck Val -> TypeCheck Val)
-> OneOrTwo (TypeCheck Val) -> TypeCheck (OneOrTwo Val)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OneOrTwo a -> f (OneOrTwo b)
traverse TypeCheck Val -> TypeCheck Val
forall a. a -> a
id (OneOrTwo (TypeCheck Val) -> TypeCheck (OneOrTwo Val))
-> OneOrTwo (TypeCheck Val) -> TypeCheck (OneOrTwo Val)
forall a b. (a -> b) -> a -> b
$ (Val -> Val -> TypeCheck Val)
-> OneOrTwo Val -> OneOrTwo Val -> OneOrTwo (TypeCheck Val)
forall a b c.
(a -> b -> c) -> OneOrTwo a -> OneOrTwo b -> OneOrTwo c
zipWith12 Val -> Val -> TypeCheck Val
app OneOrTwo Val
fv12 OneOrTwo Val
v12
leqVal' :: Force -> Pol -> MT12 -> Val -> Val -> TypeCheck ()
leqVal' :: Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
mt12 Val
u1' Val
u2' = (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
cxt -> TCContext
cxt { consistencyCheck = False }) (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
l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
ren <- getRen
enterDoc (case mt12 of
MT12
Nothing ->
String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"leqVal' (subtyping) "
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u1' 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
p 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u2'
Just (One Val
tv) ->
String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"leqVal' "
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u1' 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
p 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u2' 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
tv
Just (Two Val
tv1 Val
tv2) ->
String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"leqVal' "
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u1' 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
tv1 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
p 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u2' 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
tv2) $ do
mt12f <- mapM (mapM force) mt12
sh12 <- case mt12f of
MT12
Nothing -> Maybe TypeShape
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe TypeShape)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TypeShape
forall a. Maybe a
Nothing
Just OneOrTwo Val
tv12 -> case Except TraceError TypeShape -> Either TraceError TypeShape
forall e a. Except e a -> Either e a
runExcept (Except TraceError TypeShape -> Either TraceError TypeShape)
-> Except TraceError TypeShape -> Either TraceError TypeShape
forall a b. (a -> b) -> a -> b
$ OneOrTwo Val -> Except TraceError TypeShape
forall (m :: * -> *).
(Functor m, Monad m, MonadError TraceError m) =>
OneOrTwo Val -> m TypeShape
typeView12 OneOrTwo Val
tv12 of
Right TypeShape
sh -> Maybe TypeShape
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe TypeShape)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TypeShape
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe TypeShape))
-> Maybe TypeShape
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe TypeShape)
forall a b. (a -> b) -> a -> b
$ TypeShape -> Maybe TypeShape
forall a. a -> Maybe a
Just TypeShape
sh
Left TraceError
err -> (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
$ TraceError -> String
forall a. Show a => a -> String
show TraceError
err) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe TypeShape)
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe TypeShape)
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe TypeShape
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(Maybe TypeShape)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TypeShape
forall a. Maybe a
Nothing
case sh12 of
Just (ShSing{}) -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (ShSingL Val
v1 Val
tv1' Val
tv2) -> Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p (OneOrTwo Val -> MT12
forall a. a -> Maybe a
Just (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
tv1' Val
tv2)) Val
v1 Val
u2'
Just (ShSingR Val
tv1 Val
v2 Val
tv2') -> Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p (OneOrTwo Val -> MT12
forall a. a -> Maybe a
Just (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
tv1 Val
tv2')) Val
u1' Val
v2
Just (ShSort (ShSortC Class
Size)) -> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize Pol
p Val
u1' Val
u2'
Just (ShQuant PiSigma
Pi OneOrTwo Name
x12 OneOrTwo Domain
dom12 OneOrTwo Val
fv12) -> do
x <- do
let x :: Name
x = OneOrTwo Name -> Name
name12 OneOrTwo Name
x12
if String -> Bool
forall a. Null a => a -> Bool
null (Name -> String
suggestion Name
x) then do
case (Val
u1', Val
u2') of
(VLam Name
x Env
_ Expr
_, Val
_) -> Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
(Val
_, VLam Name
x Env
_ Expr
_) -> Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
(Val, Val)
_ -> Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
else Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Name
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
newVar x dom12 $ \ Int
_ OneOrTwo Val
xv12 -> do
u1' <- Val -> Val -> TypeCheck Val
app Val
u1' (OneOrTwo Val -> Val
forall a. OneOrTwo a -> a
first12 OneOrTwo Val
xv12)
u2' <- app u2' (second12 xv12)
tv12 <- app12 fv12 xv12
leqVal' f p (Just tv12) u1' u2'
Maybe TypeShape
_ -> do
u1 <- Val -> TypeCheck Val
reduce (Val -> TypeCheck Val) -> TypeCheck Val -> TypeCheck Val
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> TypeCheck Val
whnfClos Val
u1'
u2 <- reduce =<< whnfClos u2'
let tryForcing StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback = do
(f1,u1f) <- Bool -> Val -> TypeCheck (Bool, Val)
force' Bool
False Val
u1
(f2,u2f) <- force' False u2
case (f1,f2) of
(Bool
True,Bool
False) | Force
f Force -> Force -> Bool
forall a. Eq a => a -> a -> Bool
/= Force
R ->
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
"forcing LHS") (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
$
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
L Pol
p MT12
mt12 Val
u1f Val
u2
(Bool
False,Bool
True) | Force
f Force -> Force -> Bool
forall a. Eq a => a -> a -> Bool
/= Force
L ->
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
"forcing RHS") (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
$
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
R Pol
p MT12
mt12 Val
u1 Val
u2f
(Bool, Bool)
_ ->
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
fallback
leqCons QName
n1 [Val]
vl1 QName
n2 [Val]
vl2 = do
Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QName
n1 QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
n2) (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$
String
"leqVal': head mismatch " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
u1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" != " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
u2
case MT12
mt12 of
MT12
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
"leqVal': cannot compare constructor terms without type"
Just OneOrTwo Val
tv12 -> do
ct12 <- (Val -> TypeCheck Val) -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)
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)
mapM (QName -> Val -> TypeCheck Val
conType QName
n1) OneOrTwo Val
tv12
_ <- leqVals' f p ct12 vl1 vl2
return ()
case (u1,u2) of
(VGuard Bound Val
beta1 Val
bv1, VGuard Bound Val
beta2 Val
bv2) -> do
Pol
-> Bound Val
-> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
entailsGuard (Pol -> Pol
forall a. Switchable a => a -> a
switch Pol
p) Bound Val
beta1 Bound Val
beta2
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
forall a. Maybe a
Nothing Val
bv1 Val
bv2
(VGuard Bound Val
beta Val
u1, Val
u2) | Pol
p Pol -> [Pol] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pol
Neg,Pol
Pos] ->
Pol
-> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. Pol -> Bound Val -> TypeCheck a -> TypeCheck a
addOrCheckGuard (Pol -> Pol
forall a. Switchable a => a -> a
switch Pol
p) Bound Val
beta (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
$
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
forall a. Maybe a
Nothing Val
u1 Val
u2
(Val
u1, VGuard Bound Val
beta Val
u2) | Pol
p Pol -> [Pol] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pol
Neg,Pol
Pos] ->
Pol
-> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. Pol -> Bound Val -> TypeCheck a -> TypeCheck a
addOrCheckGuard Pol
p Bound Val
beta (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
$
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
forall a. Maybe a
Nothing Val
u1 Val
u2
(VQuant PiSigma
piSig1 Name
x1 dom1 :: Domain
dom1@(Domain Val
av1 Kind
_ Dec
dec1) Val
fv1,
VQuant PiSigma
piSig2 Name
x2 dom2 :: Domain
dom2@(Domain Val
av2 Kind
_ Dec
dec2) Val
fv2) -> do
let p' :: Pol
p' = if PiSigma
piSig1 PiSigma -> PiSigma -> Bool
forall a. Eq a => a -> a -> Bool
== PiSigma
Pi then Pol -> Pol
forall a. Switchable a => a -> a
switch Pol
p else Pol
p
if PiSigma
piSig1 PiSigma -> PiSigma -> Bool
forall a. Eq a => a -> a -> Bool
/= PiSigma
piSig2 Bool -> Bool -> Bool
|| Bool -> Bool
not (Pol -> Dec -> Dec -> Bool
leqDec Pol
p' Dec
dec1 Dec
dec2) then
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
"subtyping" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u1 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
p 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
u2 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
"failed"
else do
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' (Force -> Force
forall a. Switchable a => a -> a
switch Force
f) Pol
p' MT12
forall a. Maybe a
Nothing Val
av1 Val
av2
let dom :: Domain
dom = if (Pol
p' Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
Neg) then Domain
dom2 else Domain
dom1
let x :: Name
x = [Name] -> Name
bestName ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ if Pol
p' Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
Neg then [Name
x2,Name
x1] else [Name
x1,Name
x2]
Name
-> Domain
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Name
-> Domain
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Name -> Domain -> (Val -> m a) -> m a
new Name
x Domain
dom ((Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Val
xv -> do
bv1 <- Val -> Val -> TypeCheck Val
app Val
fv1 Val
xv
bv2 <- app fv2 xv
enterDoc (text "comparing codomain" <+> prettyTCM bv1 <+> text "with" <+> prettyTCM bv2) $
leqVal' f p Nothing bv1 bv2
(VSing Val
v1 Val
av1, VSing Val
v2 Val
av2) -> do
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
forall a. Maybe a
Nothing Val
av1 Val
av2
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
N Pol
mixed (OneOrTwo Val -> MT12
forall a. a -> Maybe a
Just (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
av1 Val
av2)) Val
v1 Val
v2
(VSing Val
v1 Val
av1, VBelow LtLe
ltle Val
v2) | Val
av1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
vSize Bool -> Bool -> Bool
&& Pol
p Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
Pos -> do
v1 <- Val -> TypeCheck Val
whnfClos Val
v1
leSize ltle p v1 v2
(VBelow LtLe
ltle1 Val
v1, VBelow LtLe
ltle2 Val
v2) ->
case (Pol
p, LtLe
ltle1, LtLe
ltle2) of
(Pol, LtLe, LtLe)
_ | LtLe
ltle1 LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
ltle2 -> LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
Le Pol
p Val
v1 Val
v2
(Pol
Neg, LtLe
Le, LtLe
Lt) -> LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
Le Pol
p (Val -> Val
vSucc Val
v1) Val
v2
(Pol
Neg, LtLe
Lt, LtLe
Le) -> LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
Lt Pol
p Val
v1 Val
v2
(Pol
p , LtLe
Lt, LtLe
Le) -> LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
Le Pol
p Val
v1 (Val -> Val
vSucc Val
v2)
(Pol
p , LtLe
Le, LtLe
Lt) -> LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
Lt Pol
p Val
v1 Val
v2
(VUp Val
v1 Val
av1, VUp Val
v2 Val
av2) -> do
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p (OneOrTwo Val -> MT12
forall a. a -> Maybe a
Just (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
av1 Val
av2)) Val
v1 Val
v2
(VUp Val
v1 Val
av1, Val
u2) -> Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
mt12 Val
v1 Val
u2
(Val
u1, VUp Val
v2 Val
av2) -> Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
mt12 Val
u1 Val
v2
(VRecord (NamedRec ConK
_ QName
n1 Bool
_ Dotted
_) [(Name, Val)]
rs1, VRecord (NamedRec ConK
_ QName
n2 Bool
_ Dotted
_) [(Name, Val)]
rs2) ->
QName
-> [Val]
-> QName
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqCons QName
n1 (((Name, Val) -> Val) -> [(Name, Val)] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Val) -> Val
forall a b. (a, b) -> b
snd [(Name, Val)]
rs1) QName
n2 (((Name, Val) -> Val) -> [(Name, Val)] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Val) -> Val
forall a b. (a, b) -> b
snd [(Name, Val)]
rs2)
(VCase Val
v1 Val
tv1 Env
env1 [Clause]
cl1, VCase Val
v2 Val
tv2 Env
env2 [Clause]
cl2) -> do
Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p (OneOrTwo Val -> MT12
forall a. a -> Maybe a
Just (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
tv1 Val
tv2)) Val
v1 Val
v2
Force
-> Pol
-> MT12
-> Val
-> Val
-> Env
-> [Clause]
-> Env
-> [Clause]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqClauses Force
f Pol
p MT12
mt12 Val
v1 Val
tv1 Env
env1 [Clause]
cl1 Env
env2 [Clause]
cl2
(VSing Val
v1 Val
av1, Val
av2) -> Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
p MT12
forall a. Maybe a
Nothing Val
av1 Val
av2
(VSort Sort Val
s1, VSort Sort Val
s2) -> Pol
-> Sort Val
-> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSort Pol
p Sort Val
s1 Sort Val
s2
(Val
a1,Val
a2) | Val
a1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
a2 -> () -> 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 ()
(Val
u1,Val
u2) -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
tryForcing (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 (Val
u1,Val
u2) of
(VApp Val
v1 [Val]
vl1, VApp Val
v2 [Val]
vl2) -> Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
f Pol
p Val
v1 [Val]
vl1 Val
v2 [Val]
vl2
(VApp Val
v1 [Val]
vl1, Val
u2) -> Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
f Pol
p Val
v1 [Val]
vl1 Val
u2 []
(Val
u1, VApp Val
v2 [Val]
vl2) -> Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
f Pol
p Val
u1 [] Val
v2 [Val]
vl2
(Val, Val)
_ -> Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
f Pol
p Val
u1 [] Val
u2 []
leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck ()
leqClauses :: Force
-> Pol
-> MT12
-> Val
-> Val
-> Env
-> [Clause]
-> Env
-> [Clause]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqClauses Force
f Pol
pol MT12
mt12 Val
v Val
tvp Env
env1 [Clause]
cls1 Env
env2 [Clause]
cls2 = [Clause]
-> [Clause]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [Clause]
cls1 [Clause]
cls2 where
loop :: [Clause]
-> [Clause]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [Clause]
cls1 [Clause]
cls2 = case ([Clause]
cls1,[Clause]
cls2) of
([],[]) -> () -> 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 ()
(Clause TeleVal
_ [Pattern
p1] Maybe Expr
mrhs1 : [Clause]
cls1', Clause TeleVal
_ [Pattern
p2] Maybe Expr
mrhs2 : [Clause]
cls2') -> do
ns <- (StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
-> [(Name, Name)] -> TypeCheck [(Name, Name)])
-> [(Name, Name)]
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
-> TypeCheck [(Name, Name)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
-> [(Name, Name)] -> TypeCheck [(Name, Name)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT [] (StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
-> TypeCheck [(Name, Name)])
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
-> TypeCheck [(Name, Name)]
forall a b. (a -> b) -> a -> b
$ Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern Pattern
p1 Pattern
p2
case (mrhs1, mrhs2) of
(Maybe Expr
Nothing, Maybe Expr
Nothing) -> () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just Expr
e1, Just Expr
e2) -> do
let tv :: Val
tv = Val -> (OneOrTwo Val -> Val) -> MT12 -> Val
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Val
vTopSort OneOrTwo Val -> Val
forall a. OneOrTwo a -> a
first12 MT12
mt12
let tv012 :: [Val]
tv012 = [Val] -> (OneOrTwo Val -> [Val]) -> MT12 -> [Val]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] OneOrTwo Val -> [Val]
forall a. OneOrTwo a -> [a]
toList12 MT12
mt12
Val
-> Pattern
-> Env
-> (Val
-> Val
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Val
-> Pattern
-> Env
-> (Val -> Val -> Env -> TypeCheck a)
-> TypeCheck a
forall (m :: * -> *) a.
MonadCxt m =>
Val -> Pattern -> Env -> (Val -> Val -> Env -> m a) -> m a
addPattern (Val
tvp Val -> Val -> Val
`arrow` Val
tv) Pattern
p2 Env
env2 ((Val
-> Val
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Val
-> Val
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Val
_ Val
pv Env
env2' ->
Rewrite
-> [Val]
-> ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Rewrite
-> [Val]
-> ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Rewrite -> [Val] -> ([Val] -> m a) -> m a
addRewrite (Val -> Val -> Rewrite
Rewrite Val
v Val
pv) [Val]
tv012 (([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ [Val]
tv012 -> do
let env1' :: Env
env1' = Env
env2' { envMap = compAssoc ns (envMap env2') }
v1 <- Env -> Expr -> TypeCheck Val
whnf (Env -> Env -> Env
forall a. Environ a -> Environ a -> Environ a
appendEnv Env
env1' Env
env1) Expr
e1
v2 <- whnf (appendEnv env2' env2) e2
leqVal' f pol (toMaybe12 tv012) v1 v2
[Clause]
-> [Clause]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
loop [Clause]
cls1' [Clause]
cls2'
type NameMap = [(Name,Name)]
alphaPattern :: Pattern -> Pattern -> StateT NameMap TypeCheck ()
alphaPattern :: Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern Pattern
p1 Pattern
p2 = do
let failure :: m a
failure = 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
"pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p1 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
p2
alpha :: a -> a -> m ()
alpha a
x1 a
x2 = do
ns <- m [(a, a)]
forall s (m :: * -> *). MonadState s m => m s
get
case lookup x1 ns of
Maybe a
Nothing -> [(a, a)] -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([(a, a)] -> m ()) -> [(a, a)] -> m ()
forall a b. (a -> b) -> a -> b
$ (a
x1,a
x2) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
ns
Just a
x2' | a
x2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x2' -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> m ()
forall {m :: * -> *} {a}. MonadError TraceError m => m a
failure
case (Pattern
p1,Pattern
p2) of
(VarP Name
x1, VarP Name
x2) -> Name
-> Name
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall {m :: * -> *} {a} {a}.
(MonadState [(a, a)] m, Eq a, Eq a, MonadError TraceError m) =>
a -> a -> m ()
alpha Name
x1 Name
x2
(ConP PatternInfo
pi1 QName
n1 [Pattern]
ps1, ConP PatternInfo
pi2 QName
n2 [Pattern]
ps2) | PatternInfo
pi1 PatternInfo -> PatternInfo -> Bool
forall a. Eq a => a -> a -> Bool
== PatternInfo
pi2 Bool -> Bool -> Bool
&& QName
n1 QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
n2 ->
(Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
())
-> [Pattern]
-> [Pattern]
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern [Pattern]
ps1 [Pattern]
ps2
(SuccP Pattern
p1, SuccP Pattern
p2) -> Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern Pattern
p1 Pattern
p2
(SizeP Expr
_ Name
x1, SizeP Expr
_ Name
x2) -> Name
-> Name
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall {m :: * -> *} {a} {a}.
(MonadState [(a, a)] m, Eq a, Eq a, MonadError TraceError m) =>
a -> a -> m ()
alpha Name
x1 Name
x2
(PairP Pattern
p11 Pattern
p12, PairP Pattern
p21 Pattern
p22) -> do
Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern Pattern
p11 Pattern
p21
Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern Pattern
p12 Pattern
p22
(ProjP Name
n1, ProjP Name
n2) -> Bool
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n2) StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall {m :: * -> *} {a}. MonadError TraceError m => m a
failure
(DotP Expr
_, DotP Expr
_) -> ()
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall a.
a
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Pattern
AbsurdP, Pattern
AbsurdP) -> ()
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall a.
a
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(ErasedP Pattern
p1, ErasedP Pattern
p2) -> Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern Pattern
p1 Pattern
p2
(UnusableP Pattern
p1, UnusableP Pattern
p2) -> Pattern
-> Pattern
-> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
alphaPattern Pattern
p1 Pattern
p2
(Pattern, Pattern)
_ -> StateT
[(Name, Name)]
(StateT TCState (ReaderT TCContext (ExceptT TraceError IO)))
()
forall {m :: * -> *} {a}. MonadError TraceError m => m a
failure
leqCases :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> [Clause] -> TypeCheck ()
leqCases :: Force
-> Pol
-> MT12
-> Val
-> Val
-> Val
-> Env
-> [Clause]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqCases Force
f Pol
pol MT12
mt12 Val
v1 Val
v Val
tvp Env
env [Clause]
cl = do
vcase <- Val -> Val -> Env -> [Clause] -> TypeCheck Val
evalCase Val
v Val
tvp Env
env [Clause]
cl
case vcase of
(VCase Val
v Val
tvp Env
env [Clause]
cl) -> (Clause
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Clause]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Force
-> Pol
-> MT12
-> Val
-> Val
-> Val
-> Env
-> Clause
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqCase Force
f Pol
pol MT12
mt12 Val
v1 Val
v Val
tvp Env
env) [Clause]
cl
Val
v2 -> Force
-> Pol
-> MT12
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqVal' Force
f Pol
pol MT12
mt12 Val
v1 Val
v2
leqCase :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> Clause -> TypeCheck ()
leqCase :: Force
-> Pol
-> MT12
-> Val
-> Val
-> Val
-> Env
-> Clause
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqCase Force
f Pol
pol MT12
mt12 Val
v1 Val
v Val
tvp Env
env (Clause TeleVal
_ [Pattern
p] Maybe Expr
Nothing) = () -> 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 ()
leqCase Force
f Pol
pol MT12
mt12 Val
v1 Val
v Val
tvp Env
env (Clause TeleVal
_ [Pattern
p] (Just Expr
e)) = 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
"leqCase" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
v StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
" --> " 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 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
pol 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM (Env -> Expr -> Val
VClos Env
env Expr
e)) (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 tv :: Val
tv = case MT12
mt12 of
MT12
Nothing -> Val
vTopSort
Just OneOrTwo Val
tv12 -> OneOrTwo Val -> Val
forall a. OneOrTwo a -> a
second12 OneOrTwo Val
tv12
Val
-> Pattern
-> Env
-> (Val
-> Val
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Val
-> Pattern
-> Env
-> (Val -> Val -> Env -> TypeCheck a)
-> TypeCheck a
forall (m :: * -> *) a.
MonadCxt m =>
Val -> Pattern -> Env -> (Val -> Val -> Env -> m a) -> m a
addPattern (Val
tvp Val -> Val -> Val
`arrow` Val
tv) Pattern
p Env
env ((Val
-> Val
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> (Val
-> Val
-> Env
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ Val
_ Val
pv Env
env' ->
Rewrite
-> [Val]
-> ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
Rewrite
-> [Val]
-> ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a)
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a.
MonadCxt m =>
Rewrite -> [Val] -> ([Val] -> m a) -> m a
addRewrite (Val -> Val -> Rewrite
Rewrite Val
v Val
pv) [Val
tv,Val
v1] (([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> ([Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ \ [Val
tv',Val
v1'] -> do
v2 <- Env -> Expr -> TypeCheck Val
whnf (Env -> Env -> Env
forall a. Environ a -> Environ a -> Environ a
appendEnv Env
env' Env
env) Expr
e
v2' <- reval v2
let mt12' = (OneOrTwo Val -> OneOrTwo Val) -> MT12 -> MT12
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Val -> Val) -> OneOrTwo Val -> OneOrTwo Val
forall a. (a -> a) -> OneOrTwo a -> OneOrTwo a
mapSecond12 (Val -> Val -> Val
forall a b. a -> b -> a
const Val
tv')) MT12
mt12
leqVal' f pol mt12' v1' v2'
leqVals' :: Force -> Pol -> OneOrTwo TVal -> [Val] -> [Val] -> TypeCheck (OneOrTwo TVal)
leqVals' :: Force
-> Pol
-> OneOrTwo Val
-> [Val]
-> [Val]
-> TypeCheck (OneOrTwo Val)
leqVals' Force
f Pol
q OneOrTwo Val
tv12 [Val]
vl1 [Val]
vl2 = do
sh12 <- OneOrTwo Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) TypeShape
forall (m :: * -> *).
(Functor m, Monad m, MonadError TraceError m) =>
OneOrTwo Val -> m TypeShape
typeView12 (OneOrTwo Val
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) TypeShape)
-> TypeCheck (OneOrTwo Val)
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) TypeShape
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Val -> TypeCheck Val) -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)
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)
mapM Val -> TypeCheck Val
force OneOrTwo Val
tv12
case (vl1, vl2, sh12) of
([], [], TypeShape
_) -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return OneOrTwo Val
tv12
(VProj PrePost
Post Name
p1 : [Val]
vs1, VProj PrePost
Post Name
p2 : [Val]
vs2, ShData QName
d OneOrTwo Val
_) -> do
Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
p1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
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
$
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
"projections"
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Name
p1 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
"and"
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {f :: * -> *}. Applicative f => f Doc -> f Doc -> f Doc
<+> Name
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Name
p2 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
"differ!"
tv12 <- (Val -> TypeCheck Val) -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)
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)
mapM (\ Val
tv -> Val -> Name -> Val -> TypeCheck Val
projectType Val
tv Name
p1 Val
VIrr) OneOrTwo Val
tv12
leqVals' f q tv12 vs1 vs2
(Val
w1:[Val]
vs1, Val
w2:[Val]
vs2, ShQuant PiSigma
Pi OneOrTwo Name
x12 OneOrTwo Domain
dom12 OneOrTwo Val
fv12) -> do
let p :: Pol
p = (Pol -> Pol) -> (Pol -> Pol -> Pol) -> OneOrTwo Pol -> Pol
forall a b. (a -> b) -> (a -> a -> b) -> OneOrTwo a -> b
oneOrTwo Pol -> Pol
forall a. a -> a
id Pol -> Pol -> Pol
polAnd ((Domain -> Pol) -> OneOrTwo Domain -> OneOrTwo Pol
forall a b. (a -> b) -> OneOrTwo a -> OneOrTwo b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity (Dec -> Pol) -> (Domain -> Dec) -> Domain -> Pol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Dec
forall a. Dom a -> Dec
decor) OneOrTwo Domain
dom12)
let dec :: Dec
dec = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
p
v1 <- Val -> TypeCheck Val
whnfClos Val
w1
v2 <- whnfClos w2
tv12 <- do
if erased p
then app12 (toTwo fv12) (Two v1 v2)
else do
let q' = Pol -> Pol -> Pol
polComp Pol
p Pol
q
applyDec dec $
leqVal' f q' (Just $ fmap typ dom12) v1 v2
case fv12 of
Two{} -> OneOrTwo Val -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)
app12 OneOrTwo Val
fv12 (Val -> Val -> OneOrTwo Val
forall a. a -> a -> OneOrTwo a
Two Val
v1 Val
v2)
One Val
fv -> Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One (Val -> OneOrTwo Val) -> TypeCheck Val -> TypeCheck (OneOrTwo Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Val -> TypeCheck Val
app Val
fv Val
v1
leqVals' f q tv12 vs1 vs2
([Val], [Val], TypeShape)
_ -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (OneOrTwo Val)
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (OneOrTwo Val))
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> TypeCheck (OneOrTwo Val)
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
"leqVals': not (compatible) function types or mismatch number of arguments when comparing "
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
<+> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM [Val]
vl1 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 "
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
<+> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM [Val]
vl2 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
<+> OneOrTwo Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM OneOrTwo Val
tv12
leqApp :: Force -> Pol -> Val -> [Val] -> Val -> [Val] -> TypeCheck ()
leqApp :: Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
f Pol
pol Val
v1 [Val]
w1 Val
v2 [Val]
w2 =
do let headMismatch :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
headMismatch = 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
"leqApp: head mismatch"
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
"!=" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
v2
let emptyOrUnit :: Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
emptyOrUnit Val
u1 Val
u2 =
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 (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
isEmptyType Val
u1) (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)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
isUnitType Val
u2) (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)) ()
headMismatch
case (Val
v1,Val
v2) of
(VUp Val
v1 Val
_, Val
v2) -> Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
f Pol
pol Val
v1 [Val]
w1 Val
v2 [Val]
w2
(Val
v1, VUp Val
v2 Val
_) -> Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
f Pol
pol Val
v1 [Val]
w1 Val
v2 [Val]
w2
(VGen Int
k1, VGen Int
k2) | Int
k1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k2 -> do
tv12 <- ((Domain -> Val) -> OneOrTwo Domain -> OneOrTwo Val
forall a b. (a -> b) -> OneOrTwo a -> OneOrTwo b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Domain -> Val
forall a. Dom a -> a
typ (OneOrTwo Domain -> OneOrTwo Val)
-> (CxtE (OneOrTwo Domain) -> OneOrTwo Domain)
-> CxtE (OneOrTwo Domain)
-> OneOrTwo Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CxtE (OneOrTwo Domain) -> OneOrTwo Domain
forall a. CxtE a -> a
domain) (CxtE (OneOrTwo Domain) -> OneOrTwo Val)
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(CxtE (OneOrTwo Domain))
-> TypeCheck (OneOrTwo Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> StateT
TCState
(ReaderT TCContext (ExceptT TraceError IO))
(CxtE (OneOrTwo Domain))
forall (m :: * -> *).
MonadCxt m =>
Int -> m (CxtE (OneOrTwo Domain))
lookupGen Int
k1
_ <- leqVals' f pol tv12 w1 w2
return ()
(VDef DefId
n, VDef DefId
m) | DefId
n DefId -> DefId -> Bool
forall a. Eq a => a -> a -> Bool
== DefId
m -> do
tv <- QName -> TypeCheck Val
forall (m :: * -> *). MonadSig m => QName -> m Val
lookupSymbTypQ (DefId -> QName
idName DefId
n)
_ <- leqVals' f pol (One tv) w1 w2
return ()
(Val
u1,Val
u2) -> if Pol
pol Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
Pos then Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
emptyOrUnit Val
u1 Val
u2 else
if Pol
pol Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
Neg then Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
emptyOrUnit Val
u2 Val
u1 else StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
headMismatch
isEmptyType :: TVal -> TypeCheck Bool
isEmptyType :: Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
isEmptyType (VDef (DefId IdKind
DatK QName
n)) = QName
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
isEmptyData QName
n
isEmptyType Val
_ = 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
isUnitType :: TVal -> TypeCheck Bool
isUnitType :: Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
isUnitType (VDef (DefId IdKind
DatK QName
n)) = QName
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
isUnitData QName
n
isUnitType Val
_ = 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
leqSort :: Pol -> Sort Val -> Sort Val -> TypeCheck ()
leqSort :: Pol
-> Sort Val
-> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSort Pol
p = Pol
-> (Sort Val
-> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> Sort Val
-> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
Monad m =>
Pol -> (a -> a -> m ()) -> a -> a -> m ()
relPolM Pol
p Sort Val
-> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSort'
leqSort' :: Sort Val -> Sort Val -> TypeCheck ()
leqSort' :: Sort Val
-> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSort' Sort Val
s1 Sort Val
s2 = 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
"universe test"
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
<+> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Sort Val
s1 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
"<="
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
<+> Sort Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Sort Val
s2 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
"failed"
case (Sort Val
s1,Sort Val
s2) of
(Sort Val
_ , Set Val
VInfty) -> () -> 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 ()
(SortC Class
c , SortC Class
c') | Class
c Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
c' -> () -> 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 ()
(Set Val
v1 , Set Val
v2) -> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize Pol
Pos Val
v1 Val
v2
(CoSet Val
VInfty , Set Val
v) -> () -> 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 ()
(Set Val
VZero , CoSet{}) -> () -> 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 ()
(CoSet Val
v1 , CoSet Val
v2) -> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize Pol
Neg Val
v1 Val
v2
(Sort Val, Sort Val)
_ -> 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
err
minSize :: Val -> Val -> Maybe Val
minSize :: Val -> Val -> Maybe Val
minSize Val
v1 Val
v2 =
case (Val
v1,Val
v2) of
(Val
VZero,Val
_) -> Val -> Maybe Val
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
VZero
(Val
_,Val
VZero) -> Val -> Maybe Val
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
VZero
(Val
VInfty,Val
_) -> Val -> Maybe Val
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v2
(Val
_,Val
VInfty) -> Val -> Maybe Val
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Val
v1
(VMax [Val]
vs,Val
_) -> [Maybe Val] -> Maybe Val
maxMins ([Maybe Val] -> Maybe Val) -> [Maybe Val] -> Maybe Val
forall a b. (a -> b) -> a -> b
$ (Val -> Maybe Val) -> [Val] -> [Maybe Val]
forall a b. (a -> b) -> [a] -> [b]
map (\ Val
v -> Val -> Val -> Maybe Val
minSize Val
v Val
v2) [Val]
vs
(Val
_,VMax [Val]
vs) -> [Maybe Val] -> Maybe Val
maxMins ([Maybe Val] -> Maybe Val) -> [Maybe Val] -> Maybe Val
forall a b. (a -> b) -> a -> b
$ (Val -> Maybe Val) -> [Val] -> [Maybe Val]
forall a b. (a -> b) -> [a] -> [b]
map (\ Val
v -> Val -> Val -> Maybe Val
minSize Val
v1 Val
v) [Val]
vs
(VSucc Val
v1', VSucc Val
v2') -> (Val -> Val) -> Maybe Val -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Val -> Val
succSize (Maybe Val -> Maybe Val) -> Maybe Val -> Maybe Val
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Maybe Val
minSize Val
v1' Val
v2'
(VGen Int
i, VGen Int
j) -> if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then Val -> Maybe Val
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Maybe Val) -> Val -> Maybe Val
forall a b. (a -> b) -> a -> b
$ Int -> Val
VGen Int
i else Maybe Val
forall a. Maybe a
Nothing
(VSucc Val
v1', VGen Int
j) -> Val -> Val -> Maybe Val
minSize Val
v1' Val
v2
(VGen Int
i, VSucc Val
v2') -> Val -> Val -> Maybe Val
minSize Val
v1 Val
v2'
maxMins :: [Maybe Val] -> Maybe Val
maxMins :: [Maybe Val] -> Maybe Val
maxMins [Maybe Val]
mvs = case [Maybe Val] -> [Val]
forall a. [Maybe a] -> [a]
compressMaybes [Maybe Val]
mvs of
[] -> Maybe Val
forall a. Maybe a
Nothing
[Val]
vs' -> Val -> Maybe Val
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Maybe Val) -> Val -> Maybe Val
forall a b. (a -> b) -> a -> b
$ [Val] -> Val
maxSize [Val]
vs'
leqSize :: Pol -> Val -> Val -> TypeCheck ()
leqSize :: Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize = LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
Le
ltSize :: Val -> Val -> TypeCheck ()
ltSize :: Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
ltSize = LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
Lt Pol
Pos
leSize :: LtLe -> Pol -> Val -> Val -> TypeCheck ()
leSize :: LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
ltle Pol
pol Val
v1 Val
v2 = 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
"leSize"
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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 (LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
pol)
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
v2) (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)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. String -> a -> a
traceSize (String
"leSize " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle 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
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v2) (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 (Val
v1,Val
v2) of
(Val, Val)
_ | Val
v1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
v2 Bool -> Bool -> Bool
&& LtLe
ltle LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
Le -> () -> 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 ()
(VSucc Val
v1,VSucc Val
v2) -> LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
ltle Pol
pol Val
v1 Val
v2
(Val
VInfty,Val
VInfty) | LtLe
ltle LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
Le -> () -> 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 ()
| Bool
otherwise -> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => String -> m ()
recoverFail String
"leSize: # < # failed"
(VApp Val
h1 [Val]
tl1,VApp Val
h2 [Val]
tl2) -> Force
-> Pol
-> Val
-> [Val]
-> Val
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqApp Force
N Pol
pol Val
h1 [Val]
tl1 Val
h2 [Val]
tl2
(Val, Val)
_ -> Pol
-> (Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a.
Monad m =>
Pol -> (a -> a -> m ()) -> a -> a -> m ()
relPolM Pol
pol (LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize' LtLe
ltle) Val
v1 Val
v2
leqSize' :: Val -> Val -> TypeCheck ()
leqSize' :: Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize' = LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize' LtLe
Le
leSize' :: LtLe -> Val -> Val -> TypeCheck ()
leSize' :: LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize' LtLe
ltle Val
v1 Val
v2 =
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
"leSize'" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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 (LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle) 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
v2) (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)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. String -> a -> a
traceSize (String
"leSize' " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v2) (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 failure :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
failure = 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
"leSize':"
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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 (LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle)
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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"failed"
case (Val
v1,Val
v2) of
(Val
VZero,Val
_) | LtLe
ltle LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
Le -> () -> 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 ()
(VSucc{}, Val
VZero) -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
failure
(Val
VInfty, Val
VZero) -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
failure
(VGen{}, Val
VZero) -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
failure
(VMax [Val]
vs,Val
_) -> (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ Val
v -> LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize' LtLe
ltle Val
v Val
v2) [Val]
vs
(Val
_,VMax [Val]
vs) -> (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)) ()]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall e (m :: * -> *) a. MonadError e m => m a -> m a -> m a
orM ([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
$ (Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Val]
-> [StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()]
forall a b. (a -> b) -> [a] -> [b]
map (LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize' LtLe
ltle Val
v1) [Val]
vs
(Val
_,Val
VInfty) | LtLe
ltle LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
Le -> () -> 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 ()
(Val
VZero, Val
VInfty) -> () -> 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 ()
(VMeta{},Val
VZero) -> LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadMeta m => LtLe -> Val -> Val -> m ()
addLe LtLe
ltle Val
v1 Val
v2
(VMeta Int
i Env
rho Int
n, VMeta Int
j Env
rho' Int
m) ->
LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadMeta m => LtLe -> Val -> Val -> m ()
addLe LtLe
ltle (Int -> Env -> Int -> Val
VMeta Int
i Env
rho (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
m))
(Int -> Env -> Int -> Val
VMeta Int
j Env
rho' (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
m))
(VMeta Int
i Env
rho Int
n, VSucc Val
v2) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize' LtLe
ltle (Int -> Env -> Int -> Val
VMeta Int
i Env
rho (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Val
v2
(VMeta Int
i Env
rho Int
n, Val
v2) -> LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadMeta m => LtLe -> Val -> Val -> m ()
addLe LtLe
ltle Val
v1 Val
v2
(VSucc Val
v1, VMeta Int
i Env
rho Int
n) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize' LtLe
ltle Val
v1 (Int -> Env -> Int -> Val
VMeta Int
i Env
rho (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
(Val
v1,VMeta Int
i Env
rho Int
n) -> LtLe
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadMeta m => LtLe -> Val -> Val -> m ()
addLe LtLe
ltle Val
v1 Val
v2
(Val, Val)
_ -> LtLe
-> Int
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize'' LtLe
ltle Int
0 Val
v1 Val
v2
leSize'' :: LtLe -> Int -> Val -> Val -> TypeCheck ()
leSize'' :: LtLe
-> Int
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize'' LtLe
ltle Int
bal Val
v1 Val
v2 = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. String -> a -> a
traceSize (String
"leSize'' " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" + " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bal String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v2) (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 failure :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
failure = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => m Doc -> m ()
recoverFailDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"leSize'':" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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]
++ Int -> String
forall a. Show a => a -> String
show Int
bal) 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 (LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle) 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"failed")
check :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
check StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
mb = 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 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
mb (() -> 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 ()) StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
failure
ltlez :: a
ltlez = case LtLe
ltle of { LtLe
Le -> a
0 ; LtLe
Lt -> -a
1 }
case (Val
v1,Val
v2) of
#ifdef STRICTINFTY
_ | v1 == v2 && ltle == Le && bal <= 0 -> return ()
(VGen i, VGen j) | i == j && bal <= -1 -> check $ isBelowInfty i
#else
(Val, Val)
_ | Val
v1 Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
v2 Bool -> Bool -> Bool
&& Int
bal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
forall {a}. Num a => a
ltlez -> () -> 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 ()
#endif
(VGen Int
i, Val
VInfty) | LtLe
ltle LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
Lt -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
check (StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *). MonadCxt m => Int -> m Bool
isBelowInfty Int
i
(Val
VZero,Val
_) | Int
bal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
forall {a}. Num a => a
ltlez -> () -> 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 ()
(Val
VZero,Val
VInfty) -> () -> 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 ()
(Val
VZero,VGen Int
_) | Int
bal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forall {a}. Num a => a
ltlez -> 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
"0 not <" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
v2
(VSucc Val
v1, Val
v2) -> LtLe
-> Int
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize'' LtLe
ltle (Int
bal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Val
v1 Val
v2
(Val
v1, VSucc Val
v2) -> LtLe
-> Int
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize'' LtLe
ltle (Int
bal Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Val
v1 Val
v2
(VPlus [Val]
vs1, VPlus [Val]
vs2) -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [Val]
vs1 [Val]
vs2
(VPlus [Val]
vs1, Val
VZero) -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [Val]
vs1 []
(Val
VZero, VPlus [Val]
vs2) -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [] [Val]
vs2
(VPlus [Val]
vs1, Val
_) -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [Val]
vs1 [Val
v2]
(Val
_, VPlus [Val]
vs2) -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [Val
v1] [Val]
vs2
(Val
VZero,Val
_) -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [] [Val
v2]
(Val
_,Val
VZero) -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [Val
v1] []
(Val, Val)
_ -> LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [Val
v1] [Val
v2]
#if (defined STRICTINFTY)
leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()
leSizePlus Lt bal vs1 vs2 = do
vs2' <- filterM varBelowInfty vs2
vs1' <- filterM varBelowInfty vs1
leSizePlus' Lt bal (vs1 List.\\ vs2') (vs2 List.\\ vs1')
leSizePlus Le bal vs1 vs2 =
leSizePlus' Le bal (vs1 List.\\ vs2) (vs2 List.\\ vs1)
#else
leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()
leSizePlus :: LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus LtLe
ltle Int
bal [Val]
vs1 [Val]
vs2 =
LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus' LtLe
ltle Int
bal ([Val]
vs1 [Val] -> [Val] -> [Val]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ [Val]
vs2) ([Val]
vs2 [Val] -> [Val] -> [Val]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ [Val]
vs1)
#endif
varBelowInfty :: Val -> TypeCheck Bool
varBelowInfty :: Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
varBelowInfty (VGen Int
i) = Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
forall (m :: * -> *). MonadCxt m => Int -> m Bool
isBelowInfty Int
i
varBelowInfty Val
_ = 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
leSizePlus' :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()
leSizePlus' :: LtLe
-> Int
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSizePlus' LtLe
ltle Int
bal [Val]
vs1 [Val]
vs2 = do
let v1 :: Val
v1 = [Val] -> Val
plusSizes [Val]
vs1
let v2 :: Val
v2 = [Val] -> Val
plusSizes [Val]
vs2
let exit :: Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
exit Bool
True = () -> 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 ()
exit Bool
False | Int
bal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => m Doc -> m ()
recoverFailDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"leSize:" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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]
++ Int -> String
forall a. Show a => a -> String
show Int
bal String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle) 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
<+> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"failed")
| Bool
otherwise = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => m Doc -> m ()
recoverFailDoc (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall {m :: * -> *}. Monad m => String -> m Doc
text String
"leSize:" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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 (LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle) 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
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
<+> 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]
++ Int -> String
forall a. Show a => a -> String
show (-Int
bal) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed"))
String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). Monad m => String -> m ()
traceSizeM (String
"leSizePlus' ltle " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" + " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bal String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LtLe -> String
forall a. Show a => a -> String
show LtLe
ltle String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Val -> String
forall a. Show a => a -> String
show Val
v2)
let ltlez :: a
ltlez = case LtLe
ltle of { LtLe
Le -> a
0 ; LtLe
Lt -> -a
1 }
case ([Val]
vs1,[Val]
vs2) of
([],[Val]
_) | Int
bal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
forall {a}. Num a => a
ltlez -> () -> 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 ()
([],[VGen Int
i]) -> do
n <- Int
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Int)
forall (m :: * -> *). MonadCxt m => Int -> m (Maybe Int)
getMinSize Int
i
case n of
Maybe Int
Nothing -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
exit Bool
False
Just Int
n -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
exit (Int
bal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall {a}. Num a => a
ltlez)
([VGen Int
i1],[VGen Int
i2]) -> do
d <- Int
-> Int
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) (Maybe Int)
forall (m :: * -> *). MonadCxt m => Int -> Int -> m (Maybe Int)
sizeVarBelow Int
i1 Int
i2
traceSizeM ("sizeVarBelow " ++ show (i1,i2) ++ " returns " ++ show d)
case d of
Maybe Int
Nothing -> Int
-> Int
-> Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
tryIrregularBound Int
i1 Int
i2 (Int
forall {a}. Num a => a
ltlez Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bal)
Just Int
k -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
exit (Int
bal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall {a}. Num a => a
ltlez)
([Val], [Val])
_ -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
exit Bool
False
tryIrregularBound :: Int -> Int -> Int -> TypeCheck ()
tryIrregularBound :: Int
-> Int
-> Int
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
tryIrregularBound Int
i1 Int
i2 Int
k = do
betas <- (TCContext -> [Bound Val])
-> StateT
TCState (ReaderT TCContext (ExceptT TraceError IO)) [Bound Val]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TCContext -> [Bound Val]
bounds
let beta = LtLe -> Measure Val -> Measure Val -> Bound Val
forall a. LtLe -> Measure a -> Measure a -> Bound a
Bound LtLe
Le ([Val] -> Measure Val
forall a. [a] -> Measure a
Measure [Int -> Val
VGen Int
i1]) ([Val] -> Measure Val
forall a. [a] -> Measure a
Measure [(Val -> Val) -> Val -> [Val]
forall a. (a -> a) -> a -> [a]
iterate Val -> Val
VSucc (Int -> Val
VGen Int
i2) [Val] -> Int -> Val
forall a. HasCallStack => [a] -> Int -> a
!! Int
k])
foldl (\ StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
result Bound Val
beta' -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
result StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall e (m :: * -> *) a. MonadError e m => m a -> m a -> m a
`orM` Pol
-> Bound Val
-> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
entailsGuard Pol
Pos Bound Val
beta' Bound Val
beta)
(recoverFail "bound not entailed")
betas
lexSizes :: LtLe -> [Val] -> [Val] -> TypeCheck ()
lexSizes :: LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
ltle [Val]
mu1 [Val]
mu2 = String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a. String -> a -> a
traceSize (String
"lexSizes " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LtLe, [Val], [Val]) -> String
forall a. Show a => a -> String
show (LtLe
ltle,[Val]
mu1,[Val]
mu2)) (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 (LtLe
ltle, [Val]
mu1, [Val]
mu2) of
(LtLe
Lt, [], []) -> 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
"lexSizes: no descent detected"
(LtLe
Le, [], []) -> () -> 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 ()
(LtLe
lt, Val
a1:[Val]
mu1, Val
a2:[Val]
mu2) -> do
b <- AssertionHandling
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Bool
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
Failure (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
$ 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
$ LtLe
-> Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leSize LtLe
ltle Pol
Pos Val
a1 Val
a2
case (lt,b) of
(LtLe
Le,Bool
False) -> 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
"lexSizes: 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
a1 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
"<=" 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
<+> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Val
a2
(LtLe
Lt,Bool
True) -> () -> 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 ()
(LtLe, Bool)
_ -> LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
ltle [Val]
mu1 [Val]
mu2
entailsGuard :: Pol -> Bound Val -> Bound Val -> TypeCheck ()
entailsGuard :: Pol
-> Bound Val
-> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
entailsGuard Pol
pol beta1 :: Bound Val
beta1@(Bound LtLe
ltle1 (Measure [Val]
mu1) (Measure [Val]
mu1')) beta2 :: Bound Val
beta2@(Bound LtLe
ltle2 (Measure [Val]
mu2) (Measure [Val]
mu2')) = 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
"entailsGuard:") 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
<+> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Bound Val
beta1 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 (Pol -> String
forall a. Show a => a -> String
show Pol
pol 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
<+> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Bound Val
beta2) (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 Pol
pol of
Pol
_ | Pol
pol Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
mixed -> do
Bool
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *). MonadAssert m => Bool -> String -> m ()
assert (LtLe
ltle1 LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
ltle2) (String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> String
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a b. (a -> b) -> a -> b
$ String
"unequal bound types"
(Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize Pol
mixed) [Val]
mu1 [Val]
mu2
(Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Pol
-> Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqSize Pol
mixed) [Val]
mu1' [Val]
mu2'
() -> 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 ()
Pol
Pos | LtLe
ltle1 LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
Lt Bool -> Bool -> Bool
|| LtLe
ltle2 LtLe -> LtLe -> Bool
forall a. Eq a => a -> a -> Bool
== LtLe
Le -> do
LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
Le [Val]
mu2 [Val]
mu1
LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
Le [Val]
mu1' [Val]
mu2'
() -> 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 ()
Pol
Pos -> do
(LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
Lt [Val]
mu2 [Val]
mu1 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> 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
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
Le [Val]
mu1' [Val]
mu2')
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall e (m :: * -> *) a. MonadError e m => m a -> m a -> m a
`orM`
(LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
Le [Val]
mu2 [Val]
mu1 StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> 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
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
Lt [Val]
mu1' [Val]
mu2')
Pol
Neg -> Pol
-> Bound Val
-> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
entailsGuard (Pol -> Pol
forall a. Switchable a => a -> a
switch Pol
pol) Bound Val
beta2 Bound Val
beta1
checkGuard :: Bound Val -> TypeCheck ()
checkGuard :: Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkGuard beta :: Bound Val
beta@(Bound LtLe
ltle Measure Val
mu Measure Val
mu') =
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
"checkGuard" 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
<+> Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
forall a.
PrettyTCM a =>
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Doc
prettyTCM Bound Val
beta) (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
$
LtLe
-> [Val]
-> [Val]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
lexSizes LtLe
ltle (Measure Val -> [Val]
forall a. Measure a -> [a]
measure Measure Val
mu) (Measure Val -> [Val]
forall a. Measure a -> [a]
measure Measure Val
mu')
addOrCheckGuard :: Pol -> Bound Val -> TypeCheck a -> TypeCheck a
addOrCheckGuard :: forall a. Pol -> Bound Val -> TypeCheck a -> TypeCheck a
addOrCheckGuard Pol
Neg Bound Val
beta TypeCheck a
cont = Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkGuard Bound Val
beta StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> TypeCheck a -> TypeCheck a
forall a b.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TypeCheck a
cont
addOrCheckGuard Pol
Pos Bound Val
beta TypeCheck a
cont = Bound Val -> TypeCheck a -> TypeCheck a
forall a.
Bound Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. MonadCxt m => Bound Val -> m a -> m a
addBoundHyp Bound Val
beta TypeCheck a
cont
leqPolM :: Pol -> PProd -> TypeCheck ()
leqPolM :: Pol
-> PProd
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqPolM Pol
p (PProd Pol
Pol.Const VarMults
_) = () -> 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 ()
leqPolM Pol
p (PProd Pol
q VarMults
m) | VarMults -> Bool
forall k a. Map k a -> Bool
Map.null VarMults
m Bool -> Bool -> Bool
&& Bool -> Bool
not (Pol -> Bool
isPVar Pol
p) =
if Pol -> Pol -> Bool
leqPol Pol
p Pol
q then () -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else 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
"polarity check " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
p 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
q String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed"
leqPolM Pol
p PProd
q = 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
"adding polarity constraint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pol -> String
forall a. Show a => a -> String
show Pol
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PProd -> String
forall a. Show a => a -> String
show PProd
q
leqPolPoly :: Pol -> PPoly -> TypeCheck ()
leqPolPoly :: Pol
-> PPoly
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqPolPoly Pol
p (PPoly [PProd]
l) = (PProd
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ())
-> [PProd]
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pol
-> PProd
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqPolM Pol
p) [PProd]
l
addPosEdge :: DefId -> DefId -> PProd -> TypeCheck ()
addPosEdge :: DefId
-> DefId
-> PProd
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
addPosEdge DefId
src DefId
tgt PProd
p = Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DefId
src DefId -> DefId -> Bool
forall a. Eq a => a -> a -> Bool
== DefId
tgt Bool -> Bool -> Bool
&& PProd -> Bool
isSPos PProd
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
st <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TCState
forall s (m :: * -> *). MonadState s m => m s
get
put $ st { positivityGraph = Arc (Rigid src) (ppoly p) (Rigid tgt) : positivityGraph st }
checkPositivityGraph :: TypeCheck ()
checkPositivityGraph :: StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
checkPositivityGraph = 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
"checking positivity") (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
st <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) TCState
forall s (m :: * -> *). MonadState s m => m s
get
let cs = TCState -> [Constrnt PPoly DefId ()]
positivityGraph TCState
st
let gr = [Constrnt PPoly DefId ()] -> Graph PPoly DefId ()
forall rigid edgeLabel flexScope.
(Eq rigid, Ord rigid, SemiRing edgeLabel) =>
[Constrnt edgeLabel rigid flexScope]
-> Graph edgeLabel rigid flexScope
buildGraph [Constrnt PPoly DefId ()]
cs
let n = Graph PPoly DefId () -> Int
forall edgeLabel rigid flexScope.
Graph edgeLabel rigid flexScope -> Int
nextNode Graph PPoly DefId ()
gr
let m0 = Int -> (Int -> Int -> PPoly) -> Matrix PPoly
forall a. Int -> (Int -> Int -> a) -> Matrix a
mkMatrix Int
n (Graph PPoly DefId () -> Int -> Int -> PPoly
forall edgeLabel rigid flexScope.
Graph edgeLabel rigid flexScope -> Int -> Int -> edgeLabel
graph Graph PPoly DefId ()
gr)
let m = Matrix PPoly -> Matrix PPoly
forall a. SemiRing a => Matrix a -> Matrix a
warshall Matrix PPoly
m0
let isDataId Int
i = case Int -> Map Int (Node DefId) -> Maybe (Node DefId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
i (Graph PPoly DefId () -> Map Int (Node DefId)
forall edgeLabel rigid flexScope.
Graph edgeLabel rigid flexScope -> Map Int (Node rigid)
intMap Graph PPoly DefId ()
gr) of
Just (Rigid (DefId IdKind
DatK QName
_)) -> Bool
True
Maybe (Node DefId)
_ -> Bool
False
let dataDiag = [ Matrix PPoly
m Matrix PPoly -> (Int, Int) -> PPoly
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
i,Int
i) | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int -> Bool
isDataId Int
i ]
mapM_ (\ PPoly
x -> Pol
-> PPoly
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
leqPolPoly Pol
forall a. SemiRing a => a
oone PPoly
x) dataDiag
put $ st { positivityGraph = [] }
telView :: TVal -> TypeCheck ([(Val, TBinding TVal)], TVal)
telView :: Val -> TypeCheck ([(Val, TBinding Val)], Val)
telView Val
tv = do
case Val
tv of
VQuant PiSigma
Pi Name
x Domain
dom Val
fv -> Name
-> Domain
-> Val
-> (Int -> Val -> Val -> TypeCheck ([(Val, TBinding Val)], Val))
-> TypeCheck ([(Val, TBinding Val)], Val)
forall a.
Name
-> Domain
-> Val
-> (Int -> Val -> Val -> TypeCheck a)
-> TypeCheck a
underAbs_ Name
x Domain
dom Val
fv ((Int -> Val -> Val -> TypeCheck ([(Val, TBinding Val)], Val))
-> TypeCheck ([(Val, TBinding Val)], Val))
-> (Int -> Val -> Val -> TypeCheck ([(Val, TBinding Val)], Val))
-> TypeCheck ([(Val, TBinding Val)], Val)
forall a b. (a -> b) -> a -> b
$ \ Int
_ Val
xv Val
bv -> do
(vTel, core) <- Val -> TypeCheck ([(Val, TBinding Val)], Val)
telView Val
bv
return ((xv, TBind x dom) : vTel, core)
Val
_ -> ([(Val, TBinding Val)], Val)
-> TypeCheck ([(Val, TBinding Val)], Val)
forall a.
a -> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Val
tv)
mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val
mkConVal :: Dotted -> ConK -> QName -> [Val] -> Val -> TypeCheck Val
mkConVal Dotted
dotted ConK
co QName
n [Val]
vs Val
vc = do
(vTel, _) <- Val -> TypeCheck ([(Val, TBinding Val)], Val)
telView Val
vc
let fieldNames = ((Val, TBinding Val) -> Name) -> [(Val, TBinding Val)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TBinding Val -> Name
forall a. TBinding a -> Name
boundName (TBinding Val -> Name)
-> ((Val, TBinding Val) -> TBinding Val)
-> (Val, TBinding Val)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Val, TBinding Val) -> TBinding Val
forall a b. (a, b) -> b
snd) [(Val, TBinding Val)]
vTel
return $ VRecord (NamedRec co n False dotted) $ zip fieldNames vs