{-# LANGUAGE TupleSections, FlexibleInstances, FlexibleContexts, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- Activate this flag if i < $i should only hold for i < #.
-- #define STRICTINFTY

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 Debug.Trace (trace)

import Abstract
import Polarity as Pol
import Value
import TCM
import PrettyTCM hiding ((<>))
import qualified PrettyTCM as P
import Warshall  -- positivity checking

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 -- trace msg 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 () -- traceM msg
{-
traceEta msg a = trace msg a
traceEtaM msg = traceM msg
-}

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 -- trace msg 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 () -- traceM msg
{-
traceMatch msg a = trace msg a
traceMatchM msg = traceM msg
-}

traceLoop :: forall a. String -> a -> a
traceLoop String
msg a
a = a
a -- trace msg 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 () -- traceM msg
{-
traceLoop msg a = trace msg a
traceLoopM msg = traceM msg
-}

traceSize :: forall a. String -> a -> a
traceSize String
msg a
a = a
a -- trace msg 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 () -- traceM msg
{-
traceSize msg a = trace msg a
traceSizeM msg = traceM msg
-}

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"

-- evaluation with rewriting -------------------------------------

{-

Rewriting rules have the form

  blocked --> pattern

this means that at the root, at most one rewriting step is possible.
Rewriting rules are considered computational, since they trigger new
(symbolic) computations.  At least they have to be applied in

- pattern matching
- equality checking
When a new rule b --> p is added, b should be in --> normal form.
Otherwise there could be inconsistencies, like adding both rules

  b --> true
  b --> false

If after adding b --> true b is rewritten to nf, then the second rule
would be true --> false, which can be captured by MiniAgda.

Also, after adding a new rule, it could be used to rewrite the old rules.

Implementation:

- add a set of local rewriting rules to the context (not to the state)
- keep values in --> weak head normal form
- untyped equality test between values

 -}

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
   -- no need to reevaluate mmeas, since only sizes

-- | When combining valuations, the old one takes priority.
--   @[sigma][tau]v = [[sigma]tau]v@
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  -- no rewriting in size expressions
      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 -- cannot rewrite projection
      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  -- since we only have rewrite rules at base types
                  -- we do not need to reduces prefixes of 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 [] -- restore invariant
                                   -- CAN'T rewrite defined fun/data
      VGen Int
i -> Val -> TypeCheck Val
reduce (Int -> Valuation -> Val
valuateGen Int
i Valuation
valu)  -- CAN rewrite variable

      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
    {-
      VQuant pisig x dom env b -> do
        dom' <- mapM reval dom
        env' <- reEnv env
        return $ VQuant pisig x dom' env' b
    -}
      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)  -- do not force at this point

      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


-- TODO: singleton Sigma types
-- <t : Pi x:a.f> = Pi x:a <t x : f x>
-- <t : A -> B  > = Pi x:A <t x : B>
-- <t : <t' : a>> = <t' : a>
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
{-
-- This is a bit of a hack (finding a fresh name)
-- <t : Pi x:a.b> = Pi x:a <t x : b>
-- <t : Pi x:a.f> = Pi x:a <t x : f x>
-- <t : <t' : a>> = <t' : a>
vSing :: Val -> TVal -> TVal
vSing v (VQuant Pi x dom env b)
  | not (emptyName x) = -- xv `seq` x' `seq`
     (VQuant Pi x dom (update env xv v) $ Sing (App (Var xv) (Var x)) b)
      where xv = fresh ("vSing#" ++ suggestion x)
vSing v (VQuant Pi x dom env b) =
--  | otherwise =
     (VQuant Pi x' dom (update env xv v) $ Sing (App (Var xv) (Var x')) b')
      where xv = fresh ("vSing#" ++ suggestion x)
            x' = fresh $ if emptyName x then "xSing#" else suggestion x
            b' = parSubst (\ y -> Var $ if y == x then x' else y) b
vSing _ tv@(VSing{}) = tv
vSing v tv           = VSing v tv
-}

-- reduce the root of a value
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 v v'  tests values for untyped equality
-- precond: v v' are in --> whnf
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 -- includes all size expressions
--    (VSucc v1, VSucc v2) -> equal v1 v2  -- NO REDUCING NECC. HERE (Size expr)
    (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
$  -- NO RED. NECC. (Type)
         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 -> -- PROBLEM: DOM. MISSING, CAN'T "up" fresh variable
      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)
{-
    (VLam x1 env1 b1, VLam x2 env2 b2) -> -- PROBLEM: DOMAIN MISSING
         addName x1 $ \ vx -> do          -- CAN'T "up" fresh variable
               do v1 <- whnf (update env1 x1 vx) b1
                  v2 <- whnf (update env2 x2 vx) b2
                  equal v1 v2
-}
    (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

{- LEADS TO NON-TERMINATION
-- equal' v1 v2  tests values for untyped equality
-- v1 v2 are not necessarily in --> whnf
equal' v1 v2 = do
  v1' <- reduce v1
  v2' <- reduce v2
  equal v1' v2'
-}

-- normalization -----------------------------------------------------

reify :: Val -> TypeCheck Expr
reify :: Val -> TypeCheck Expr
reify Val
v = (Int, Bool) -> Val -> TypeCheck Expr
reify' (Int
5, Bool
True) Val
v

-- normalize to depth m
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  -- default recursive call
  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)      -> -- error $ "cannot reify meta-variable " ++ show v0
                            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  -- TODO: dec!?
    (VUp Val
v Val
tv)           -> Val -> TypeCheck Expr
reify Val
v -- TODO: type directed reification
    (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) -- forgotten the meaning of the boolean, WAS: False)
                             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 -- TODO: properly evaluate clauses!!
    (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")

-- printing (conversion to Expr) -------------------------------------

-- similar to reify
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
{-
    VSort (CoSet v) -> (Sort . CoSet) <$> toExpr v
    VSort (Set v)   -> (Sort . Set) <$> toExpr v
    VSort (SortC s) -> return $ Sort (SortC 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
{-
    VLam x rho e    -> addNameEnv x rho $ \ x rho ->
      Lam defaultDec x <$> closToExpr rho e
-}
    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

{-
addBindEnv :: TBind -> Env -> (Env -> TypeCheck a) -> TypeCheck a
addBindEnv (TBind x dom) rho cont = do
  let dom' = fmap (VClos rho) dom
  newWithGen x dom' $ \ k _ ->
    cont (update rho x (VGen k))
-}

addNameEnv :: Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a
--addNameEnv "" rho cont = cont "" rho
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 -- error $ "internal error: variable " ++ show x ++ " comes without domain"
  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 -- \ x rho -> cont (VarP x) rho
    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 -- \ ps rho -> cont (ConP pi n ps) rho
    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 BindClosToExpr a where
  bindClosToExpr :: Env -> a -> (Env -> a -> TCM b) -> TCM b

instance ClosToExpr a => BindClosToExpr (TBinding a) where
  bindClosToExpr
-}

class ClosToExpr a where
  closToExpr     :: Env -> a -> TypeCheck a
  bindClosToExpr :: Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b

  -- default : no binding
  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 Pi tel mu@TMeasure{} e | null tel -> pi <$> closToExpr rho mu   <*> closToExpr rho e
      Quant Pi tel beta@TBound{} e | null tel -> pi <$> closToExpr rho beta <*> closToExpr rho 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
--       Quant piSig tel tb e -> bindClosToExpr rho tel $ \ rho tel ->
--         bindClosToExpr rho tb $ \ rho tb -> Quant piSig tel tb <$> closToExpr rho 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

-- evaluation --------------------------------------------------------

-- | Weak head normal form.
--   Monadic, since it reads the globally defined constants from the signature.
--   @let@s are expanded away.

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
{-
-- ALT: remove erased lambdas entirely
    Lam dec x e1 | erased dec -> whnf env e1
                 | otherwise -> return $ VLam x env e1
-}
    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  -- Pi is strict in its first argument
      return $ VQuant pisig x dom' $ vLam x env b

    -- a measured type evaluates to
    -- - a bounded type if measure present in environment (rhs of funs)
    -- - otherwise to a measured type (lhs of funs)
    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 -- not adding measure constraint to context!
      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
           -- throwErrorMsg $ "panic: whnf " ++ show e ++ " : no measure in environment " ++ show env
        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  -- not adding measure constraint to context!
          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

    -- coinductive and anonymous records are treated lazily:
    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

{-
-- ALT: filter out all erased arguments from application
    App e1 el -> do v1 <- whnf env e1
                    vl <- liftM (filter (/= VIrr)) $ mapM (whnf env) el
                    app v1 vl
-}
    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
{-
    App e1 el -> do v1 <- whnf env e1
                    vl <- mapM (whnf env) el
                    app v1 vl
-}

    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
                  -- trace ("case head evaluates to " ++ showVal v) $ return ()

    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           -- succ is strict
                  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   -- max is strict
                  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   -- plus is strict
                  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 (ConK DefPat) n) -> throwErrorMsg $ "internal error: whnf of defined pattern " ++ show 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
{-
    Con co n -> return $ VCon co n

    Def n -> return $ VDef n

    Let n -> do sig <- gets signature
                let (LetSig _ v) = lookupSig n sig
                return v
--                let (LetSig _ e) = lookupSig n sig
--                whnf [] e
-}
    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) -- return VIrr -- NEED TO KEEP because of eta-exp!
    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 = -- trace ("whnfClos " ++ show v) $
  case Val
v of
    (VClos Env
e Expr
rho) -> Env -> Expr -> TypeCheck Val
whnf Env
e Expr
rho
    -- (VApp (VProj Pre n) [u]) -> app u (VProj Post n) -- NO EFFECT
    (VApp (VDef (DefId IdKind
FunK QName
n)) [Val]
vl) -> QName -> [Val] -> TypeCheck Val
appDef QName
n [Val]
vl -- THIS IS TO SOLVE A PROBLEM
    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
{- THE PROBLEM IS that
  (tail (x Up Stream)) Up Stream is a whnf, because Up Stream is lazy
  in equality checking this is a problem when the Up is removed.
-}

-- evaluate in standard environment
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

-- <t : Pi x:a.b> = Pi x:a <t x : b>
-- <t : <t' : a>> = <t' : a>
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 -- v <- whnf rho e
  Val -> Val -> TypeCheck Val
vSing Val
v Val
tv
{-
sing env' e (VPi dec x av env b)  = do
  return $ VPi dec x' av env'' (Sing (App e (Var x')) b)
    where env'' = env' ++ env  -- super ugly HACK
          x'    = if x == "" then fresh env'' else x
    -- Should work with just x since shadowing is forbidden
sing _ _ tv@(VSing{}) = return $ tv
sing env e tv = do v <- whnf env e      -- singleton strict, is this OK?!
                   return $ VSing v 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 -- no rec value here
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

-- in app u v, u might be a VDef (e.g. when coming from reval)
app :: Val -> Clos -> TypeCheck Val
app :: Val -> Val -> TypeCheck Val
app = Bool -> Val -> Val -> TypeCheck Val
app' Bool
True

-- | Application of arguments and projections.
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      -- inductive constructors are strict!
              return $ VApp h (vl ++ [v])
--            VDef n -> appDef n [v]
--            VApp (VDef id) vl -> VApp (VDef id) (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])

-- VSing is a type!
--           VSing u (VQuant Pi x dom fu) -> vSing <$> app u v <*> app fu 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 u1 (VQuant Pi x dom rho b) -> do
{-
-- ALT: erased functions are not applied to their argument!
              v1 <- if erased dec then return v else app v [w]  -- eta-expand w ??
-}
              v1 <- app u1 v  -- eta-expand v ??
              bv <- whnf (update rho x v) b
              up False v1 bv
-}
            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
{- 2010-11-01 this breaks extraction for System U example
            VIrr -> throwErrorMsg $ "app internal error: " ++ show (VApp u [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 -> TypeCheck Val) -> Val -> TypeCheck Val
forall a b. (a -> b) -> a -> b
$ Val -> [Val] -> Val
VApp Val
u [Val
v]
--
-- app :: Val -> [Val] -> TypeCheck Val
-- app u [] = return $ u
-- app u c = do
--          case (u,c) of
--             (VApp u2 c2,_) -> app u2 (c2 ++ c)
--             (VLam x env e,(v:vl))  -> do v' <- whnf (update env x v) e
--                                          app v' vl
--             (VDef n,_) -> appDef n c
--             (VUp v (VPi dec x av rho b), w:wl) -> do
-- {-
-- -- ALT: erased functions are not applied to their argument!
--               v1 <- if erased dec then return v else app v [w]  -- eta-expand w ??
-- -}
--               v1 <- app v [w]  -- eta-expand w ??
--               bv <- whnf (update rho x w) b
--               v2 <- up v1 bv
--               app v2 wl
-- {-
-- -- ALT: VIrr consumes applications
--             (VIrr,_) -> return VIrr
--  -}
--             (VIrr,_) -> throwErrorMsg $ "app internal error: " ++ show (VApp u c)
--             _ -> return $ VApp u c


-- unroll a corecursive definition one time (until constructor appears)
force' :: Bool -> Val -> TypeCheck (Bool, Val)
force' :: Bool -> Val -> TypeCheck (Bool, Val)
force' Bool
b (VSing Val
v Val
tv) = do  -- for singleton types, force type!
  (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 eta expansion
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
{-
 --trace ("force " ++ show v) $
    do sig <- gets signature
       case lookupSig n sig of
         (FunSig CoInd t cl True) -> do m <- matchClauses [] cl []
                                        case m of
                                          Just v' -> force v'
                                          Nothing -> return v
         _ -> return 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 = -- trace ("forcing " ++ show 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

-- apply a recursive function
-- corecursive ones are not expanded even if the arity is exceeded
-- this is because a coinductive type needs to be destructed by pattern matching
appDef :: QName -> [Val] -> TypeCheck Val
appDef :: QName -> [Val] -> TypeCheck Val
appDef QName
n [Val]
vl = --trace ("appDef " ++ n) $
    do
      -- identifier might not be in signature yet, e.g. ind.-rec.def.
      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

-- reflection and reification  ---------------------------------------

-- TODO: eta for builtin sigma-types !?

-- up force v tv
-- force==True also expands at coinductive type
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

{- Most of the code to eta expand on data types is in
   TypeChecker.hs "typeCheckDeclaration"

 Currently, eta expansion only happens at data *types* with exactly
one constructor.  In a first step, this will be extended to
non-recursive pattern inductive families.

The strategy is: match type value with result type for all the constructors
0. if there are no matches, eta expand to * (VIrr)
1. if there is exactly one match, eta expand accordingly using destructors
2. if there are more matches, do not eta-expand

up{Vec A (suc n)} x = vcons A n (head A n x) (tail A n x)

up{Vec Bool (suc zero)} x
  = vcons Bool zero (head Bool zero x) (tail Bool zero x)

For vcons
- the patterns of  Vec : (A : Set) -> Nat -> Set  are  [A,suc n]
- matching  Bool,suc zero  against  A,suc n  yields A=Bool,n=zero
- this means we can eta expand to vcons
- go through the fields of vcons
  - if Index use value obtained by matching
  - if Field destr, use  destr <all pars> <all indices> x

-}

-- matchingConstructors is for use in checkPattern
-- matchingConstructors (D vs)  returns all the constructors
-- each as tuple (ci,rho)
-- of family D whose target matches (D vs) under substitution rho
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' d []
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
-- throwErrorMsg $ "matchingConstructors: not a data type: " ++ show v -- return []

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}) -> -- if (null cs) then ret [] else do -- no constructor
      Bool
-> [Val]
-> Val
-> [ConstructorInfo]
-> TypeCheck [(ConstructorInfo, Env)]
matchingConstructors'' Bool
True [Val]
vl Val
dv [ConstructorInfo]
cs

-- matchingConstructors''
-- Arguments:
--   symm     symmetric match
--   vl       arguments to D (instance of D)
--   dv       complete type value of D
--   cs       constructors
-- Returns a list [(ci,rho)] of matching constructors together with the
--   environments which are solutions for the free variables in the constr.type
-- this is also for use in upData
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)
          -- list of patterns ps where D ps is the constructor target
      (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           -- eta   : must the field etaExpand be set of the data type
  -> QName          -- d     : the name of the data types
  -> [Val]          -- vl    : the arguments of the data type
  -> TypeCheck (MatchingConstructors
     ( Co           -- co    : coinductive type?
     , [Val]        -- parvs : the parameter half of the arguments
     , Env          -- rho   : the substitution for the index variables to arrive at d vl
     , [Val]        -- indvs : the index values of the constructor
     , ConstructorInfo -- ci : the only matching constructor
     ))
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
  -- when checking a mutual data decl, the sig entry of the second data
  -- is not yet in place when checking the first, thus, lookup may fail
  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 -- no constructor: empty type
       -- for each constructor, match its core against the type
      -- produces a list of maybe (c.info, environment)
      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
        -- exactly one matching constructor: can eta expand
--        [(ci,env)] -> if not (eta `implies` cEtaExp ci) then return UnknownConstructors else do
        [(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
          -- get list of index values from environment
          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)
        -- more or less than one matching constructors: cannot eta expand
        [(ConstructorInfo, Env)]
l -> -- trace ("getMatchingConstructor: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show 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)
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          -- d     : the name of the data types
  -> [Val]          -- vl    : the arguments of the data type
  -> TypeCheck
     (Maybe         -- Nothing if not a record type
       [(Name       -- list of projection names
        ,TVal)])    -- and their instantiated type R ... -> C
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
      -- for each argument of constructor, get value
      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
            -- lookup type sig  t  of destructor  d
            t <- Name -> TypeCheck Val
forall (m :: * -> *). MonadSig m => Name -> m Val
lookupSymbTyp Name
d
            -- pi-apply destructor type to parameters and indices
            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

-- similar to piApp, but for record types and projections
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 -- apply to record arg
    Val
_ -> TypeCheck Val
forall {a}.
StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) a
fail1

-- eta expand  v  at data type  n vl
upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val
upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val
upData Bool
force Val
v QName
n [Val]
vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show 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) ->
      -- lazy eta-expansion for coinductive records like streams!
      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
          -- get list of index values from environment
          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]
          -- for each argument of constructor, get value
          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
                -- lookup type sig  t  of destructor  d
                LetSig {symbTyp = t, definingVal = w} <- Name
-> StateT
     TCState (ReaderT TCContext (ExceptT TraceError IO)) SigDef
forall (m :: * -> *). MonadSig m => Name -> m SigDef
lookupSymb Name
d
                -- pi-apply destructor type to parameters, indices and value v
                t' <- piApps t piv
                -- recursively eta expand  (d <pars> v)
                -- OLD, defined projections:
                -- w <- foldM (app' False) w piv -- LAZY: only unfolds let, not def
                -- NEW, builtin projections:
                w <- app' False v (VProj Post d)
                up False w t' -- now: LAZY

          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
--          v' <- foldM app (vCon (coToConK co) (cName ci)) vs -- 2012-01-22 PARS GONE: (pars ++ vs)
          ret v'
    -- more constructors or unknown situation: do not eta expand
    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

{-
-- eta expand  v  at data type  n vl
upData :: Bool -> Val -> Name -> [Val] -> TypeCheck Val
upData force v n vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show vl) $
 do
  let ret v' = traceEta ("Eta-expanding: " ++ show v ++ " --> " ++ show v' ++ " at type " ++ n ++ show vl) $ return v'
  -- when checking a mutual data decl, the sig entry of the second data
  -- is not yet in place when checking the first, thus, lookup may fail
  sig <- gets signature
  case Map.lookup n sig of
    Just (DataSig {symbTyp = dv, numPars = npars, isCo = co, constructors = cs, etaExpand = True}) -> if (null cs) then ret VIrr else do -- no constructor: empty type
      let (pars, inds) = splitAt npars vl
      -- for each constructor, match its core against the type
      -- produces a list of maybe (c.info, environment)
      cenvs <- matchingConstructors'' False vl dv cs
      -- traceM $ "Matching constructors: " ++ show cenvs
      case cenvs of
        -- exactly one matching constructor: can eta expand
        [(ci,env)] -> if not (cEtaExp ci) then return v else
         if (co==CoInd && not force) then return $ VUp v (VApp (VDef $ DefId Dat n) vl) else do
          -- get list of index values from environment
          let fis = cFields ci
          let indices = filter (\ fi -> fClass fi == Index) fis
          let indvs = map (\ fi -> lookupPure env (fName fi)) indices
          let piv = pars ++ indvs ++ [v]
          -- for each argument of constructor, get value
          let arg (FieldInfo { fName = x, fClass = Index }) =
                lookupEnv env x
              arg (FieldInfo { fName = d, fClass = Field _ }) = do
                -- lookup type sig  t  of destructor  d
                t <- lookupSymbTyp d
                -- pi-apply destructor type to parameters, indices and value v
                t' <- piApps t piv
                -- recursively eta expand  (d <pars> v)
                -- WAS: up (VDef (DefId Fun d) `VApp` piv) t'
                up False (VDef (DefId Fun d) `VApp` piv) t' -- now: LAZY
          vs <- mapM arg fis
          v' <- foldM app (vCon co (cName ci)) (pars ++ vs)
          ret v'
        -- more or less than one matching constructors: cannot eta expand
        l -> -- trace ("Eta: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show vl) $
               return v
    _ -> return v
-}

{-
      let matchC (c, ps, ds) =
            do menv <- nonLinMatchList [] ps inds dv
               case menv of
                 Nothing -> return False
                 Just env -> do
                   let grps = groupBy (\ (x,_) (y,_) -> x == y) env
                   -- TODO: now compare elements in the group
                   -- NEED types for equality check
                   -- trivial if groups are singletons
                   return $ all (\ l -> length l <= 1) grps
      cs' <- filterM matchC cs
      case cs' of
        [] -> return $ VIrr
        [(c,_,ds)] ->  do
          let parsv = pars ++ [v]
          let aux d = do
               -- lookup type sig  t  of destructor  d
               let FunSig { symbTyp = t } = lookupSig d sig
               -- pi-apply destructor type to parameters and value v
               t' <- piApps t parsv
               -- recursively eta expand  (d <pars> v)
               up (VDef d `VApp` parsv) t'
          vs <- mapM aux ds
          app (VCon co c) (pars ++ vs)
        _ -> return v
    _ -> return v
-}

{-
refl : [A : Set] -> [a : A] -> Id A a a
up{Id T t t'} x
  Id T t t' =?= Id A a a  --> A = T, a = t, a = t'
-}

{- OLD CODE FOR NON-DEPENDENT RECORDS ONLY
    -- erase if n is a empty type
    (DataSig {constructors = []}) -> return $ VIrr
    -- eta expand v if n is a tuple type
    (DataSig {isCo = co, constructors = [c], destructors = Just ds}) -> do
       let vlv = vl ++ [v]
       let aux d = do -- lookup type sig  t  of destructor  d
                      let FunSig { symbTyp = t } = lookupSig d sig
                      -- pi-apply destructor type to parameters and value v
                      t' <- piApps t vlv
                      -- recursively eta expand  (d <pars> v)
                      up (VDef d `VApp` vlv) t'
       vs <- mapM aux ds
       app (VCon co c) (vl ++ vs) -- (map (\d -> VDef d `VApp` (vl ++ [v])) ds)
    _ -> return v
END OLD CODE -}

-- pattern matching ---------------------------------------------------

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  -- REWRITE before matching (2010-07-12 dysfunctional because of lazy?)
  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 -- no need to try absurd clauses
          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

    -- done matching: eval clause body in env and apply it to remaining arsg
    ([], [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

    -- too few arguments to fire clause: give up
    ([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 = --trace (show env ++ show v0) $
  do
    -- force against constructor pattern or pair pattern
    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 _,_) -> return $ Just env  -- TOO BAD, DOES NOT WORK (eta!)
      (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 -- | x == y -> return $ Just env
--  The following case is NOT IMPOSSIBLE:
--      (ConP _ x pl,VApp (VDef (DefId (ConK _) y)) vl) -> failValInv 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
      -- If a value is a dotted record value, we do not succeed, since
      -- it is not sure this is the correct constructor.
      (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

-- * Typed Non-linear Matching -----------------------------------------

type GenToPattern = [(Int,Pattern)]
type MatchState = (Env, GenToPattern)

-- @nonLinMatch True@ allows also instantiation in v0
-- this is useful for finding all matching constructors
-- for an erased argument in checkPattern
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
  -- force against constructor pattern
  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 -- no check in case of non-lin!
    (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
    -- Here, we do accept dotted constructors, since we are abusing this for unification.
    (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
    -- if the match against an unconfirmed constructor
    -- we can succeed, but not compute a sensible environment
    (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
    -- Check that the previous solution for @x@ is equal to @v@.
    -- Here, we need the type!
    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 symm env ps vs tv
-- typed non-linear matching of patterns ps against values vs at type tv
--   env   is the accumulator for the solution of the matching
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


-- | Expand a top-level pattern synonym
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

---------------------------------------------------------------------------
-- * Unification
---------------------------------------------------------------------------


#if MIN_VERSION_base(4,11,0)

-- From ghc 8.4, Semigroup superinstace of Monoid instance is mandatory.

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

-- | Occurrence check @nocc ks v@ (used by 'SPos' and 'TypeCheck').
--   Checks that generic values @ks@ does not occur in value @v@.
--   In the process, @tv@ is normalized.
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
    -- traceM ("nocc " ++ show v)
    v <- Val -> TypeCheck Val
whnfClos Val
v
    case v of
      -- neutrals
      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
      -- Binders:
      -- ALT: do not evaluate under binders (just check environment).
      -- This is less precise but more efficient. Can give false alarms.
      -- Still sound. (Should maybe done first, like in Agda).
      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
      -- pairs
      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)
      -- sizes
      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)
      -- impossible: closure (reduced away)
      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)


-- heterogeneous typed equality and subtyping ------------------------

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'
-- eqValBool tv v v' = (eqVal tv v v' >> return True) `catchError` (\ _ -> return False)

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))


-- force history
data Force = N | L | R -- not yet, left , right
    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

{-
-- WONTFIX: FOR THE FOLLOWING TO BE SOUND, ONE NEEDS COERCIVE SUBTYPING!
-- the problem is that after extraction, erased arguments are gone!
-- a function which does not use its argument can be used as just a function
-- [A] -> A <= A -> A
-- A <= [A]
leqDec :: Pol -> Dec -> Dec -> Bool
leqDec SPos  dec1 dec2 = erased dec2 || not (erased dec1)
leqDec Neg   dec1 dec2 = erased dec1 || not (erased dec2)
leqDec mixed   dec1 dec2 = erased dec1 == erased dec2
-}

-- subtyping for erasure disabled
-- but subtyping for polarities!
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)

-- subtyping ---------------------------------------------------------

subtype :: Val -> Val -> TypeCheck ()
subtype :: Val
-> Val
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
subtype Val
v1 Val
v2 = -- enter ("subtype " ++ show v1 ++ "  <=  " ++ show 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

-- Pol ::= Pos | Neg | mixed
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)

-- view the shape of a type or a pair of types
data TypeShape
  = ShQuant PiSigma
            (OneOrTwo Name)
            (OneOrTwo Domain)
            (OneOrTwo FVal)      -- both are function types
  | ShSort  SortShape            -- sort of same shape
  | ShData  QName (OneOrTwo TVal)-- same data, but with possibly different args
  | ShNe    (OneOrTwo TVal)      -- both neutral
  | ShSing  Val TVal             -- 1 and singleton
  | ShSingL Val TVal TVal        -- 2 and the left is a singleton
  | ShSingR TVal Val TVal        -- 2 and the right is a singleton
  | 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              -- same sort constant
  | ShSet   (OneOrTwo Val)     -- Set i and Set j
  | ShCoSet (OneOrTwo Val)     -- CoSet i and CoSet j
    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 does not normalize!
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)  -- stuck fun
    VApp (VGen Int
i) [Val]
vs             -> OneOrTwo Val -> TypeShape
ShNe (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)  -- type variable
    VGen Int
i                       -> OneOrTwo Val -> TypeShape
ShNe (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)  -- type variable
    VCase{}                      -> OneOrTwo Val -> TypeShape
ShNe (Val -> OneOrTwo Val
forall a. a -> OneOrTwo a
One Val
tv)  -- stuck case
    Val
_                            -> TypeShape
ShNone -- error $ "typeView " ++ show tv

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 :: OneOrTwo TVal -> TypeCheck 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

-- if m12 = Nothing, we are checking subtyping, otherwise we are
-- comparing objects or higher-kinded types
-- if two types are given (heterogeneous equality), they need to be
-- of the same shape, otherwise they cannot contain common terms
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
 -- 2013-03-30 During subtyping, it is fine to add any size hypotheses.
 l <- StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) Int
forall (m :: * -> *). MonadCxt m => m Int
getLen
 ren <- getRen
 enterDoc (case mt12 of
  MT12
Nothing -> -- text ("leqVal' (subtyping) " ++ show  (Map.toList $ ren) ++ " |-")
             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) -> -- text ("leqVal' " ++ show  (Map.toList $ ren) ++ " |-")
             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) -> -- text ("leqVal' " ++ show  (Map.toList $ ren) ++ " |-")
             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
{-
    ce <- ask
    trace  (("rewrites: " +?+ show (rewrites ce)) ++ "  leqVal': " ++ show ce ++ "\n |- " ++ show u1' ++ "\n  <=" ++ show p ++ "  " ++ show u2') $
-}
    mt12f <- mapM (mapM force) mt12 -- leads to LOOP, see HungryEta.ma
    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

      -- subtyping directed by common type shape

      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 () -- two terms are equal at singleton type!
      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'

{-  functions are compared pointwise

   Gamma, p(x:A) |- t x : B  <=  Gamma', p'(x:A') |- t' x : B'
   ----------------------------------------------------------
   Gamma |- t : p(x:A) -> B  <=  Gamma' |- t' : p'(x:A') -> B'
-}
      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'
{-
      Just (VPi x1 dom1 env1 b1, VPi x2 dom2 env2 b2)  ->
         new2 x1 (dom1, dom2) $ \ (xv1, xv2) -> do
            u1' <- app u1' xv1
            u2' <- app u2' xv2
            tv1' <- whnf (update env1 x1 xv1) b1
            tv2' <- whnf (update env2 x2 xv2) b2
            leqVal' f p (Just (tv1', tv2')) u1' u2'
-}


      -- structural subtyping (not directed by types)

      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 -- (u1f /= u1,u2f /= u2) of

              (Bool
True,Bool
False) | Force
f Force -> Force -> Bool
forall a. Eq a => a -> a -> Bool
/= Force
R -> -- only unroll one side
                 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)
_ -> -- enter ("not forcing " ++ show (f1,f2,f)) $
                     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 ()
{-
       leqStructural u1 u2 where
          leqStructural u1 u2 =
-}
       case (u1,u2) of

{-
  C = C'  (proper: C' entails C, but I do not want to implement entailment)
  Gamma, C |- A  <=  Gamma', C' |- A'
  -----------------------------------------
  Gamma |- C ==> A  <=  Gamma' |- C' ==> A'
-}
              (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
 {-
  p' <= p
  Gamma' |- A' <= Gamma |- A
  Gamma, p(x:A) |- B <= Gamma', p'(x:A') |- B'
  ---------------------------------------------------------
  Gamma |- p(x:A) -> B : s <= Gamma' |- p'(x:A') -> B' : s'
-}
              (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
                    -- take smaller domain
                    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  -- compare for eq.

              (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

{- 2012-01-28 now vSize is VBelow Le Infty

              -- extra cases since vSize is not implemented as VBelow Le Infty
              (u1,u2) | isVSize u1 && isVSize u2 -> return ()
              (VSort (SortC Size), VBelow{}) -> leqStructural (VBelow Le VInfty) u2
              (VBelow{}, VSort (SortC Size)) -> leqStructural u1 (VBelow Le VInfty)
-}
              -- care needed to not make <=# a subtype of <#
              (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  -- careful here
                  (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  -- careful here

              -- unresolved eta-expansions (e.g. at coinductive type)
              (VUp Val
v1 Val
av1, VUp Val
v2 Val
av2) -> do
                  -- leqVal' f p Nothing av1 av2      -- do not compare types
                  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  -- OR: Just(tv1,tv2) ?
              (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)

{-
              -- the following three cases should be impossible
              -- but aren't.  I gave up on this bug -- 2012-01-25
              -- FOUND IT

              (VRecord (NamedRec _ n1 _) rs1,
               VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 (map snd rs1) n2 vl2

              (VApp v1@(VDef (DefId (ConK _) n1)) vl1,
               VRecord (NamedRec _ n2 _) rs2) -> leqCons n1 vl1 n2 (map snd rs2)

              (VApp v1@(VDef (DefId (ConK _) n1)) vl1,
               VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 vl1 n2 vl2
-}

              -- smart equality is not transitive
              (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 -- FIXED: do not have type here, but v1,v2 are neutral
                 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

{- REMOVED, NOT TRANSITIVE
              (VCase v env cl, v2) -> leqCases (switch f) (switch p) (switch mt12) v2 v env cl
              (v1, VCase v env cl) -> leqCases f p mt12 v1 v env cl
-}
              (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  -- subtyping ax
              (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'
{-
-- naive implementation for now
leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck ()
leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where
  loop cls1 cls2 = case (cls1,cls2) of
    ([],[]) -> return ()
    (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do
      eqPattern p1 p2
      case (mrhs1, mrhs2) of
        (Nothing, Nothing) -> return ()
        (Just e1, Just e2) -> do
            let tv = maybe vTopSort first12 mt12
            let tv012 = maybe [] toList12 mt12
            addPattern (tvp `arrow` tv) p1 env1 $ \ _ pv env' ->
              addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do
                v1  <- whnf (appendEnv env' env1) e1
                v2  <- whnf (appendEnv env' env2) e2
                leqVal' f pol (toMaybe12 tv012) v1 v2
            loop cls1' cls2'

eqPattern :: Pattern -> Pattern -> TypeCheck ()
eqPattern p1 p2 = if p1 == p2 then return () else throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2
-}

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 f p tv1 v1 v tv env cl
-- checks whether  v1 <=p (VCase v tv env cl) : tv1
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

-- absurd cases need not be checked
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    -- ++ "  :  " ++ show mt12) $
-- the dot patterns inside p are only valid in environment env
  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 -- 2010-09-10, WHY?
      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'

-- compare spines (see rule Al-App-Ne, Abel, MSCS 08)
-- q ::= mixed | Pos | Neg
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!"
        -- recoverFail $ "projections " ++ show p1 ++ " and " ++ show p2 ++ " 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 -- WAS: , erased = erased $ decor $ first12 dom12 }
      v1 <- Val -> TypeCheck Val
whnfClos Val
w1
      v2 <- whnfClos w2
      tv12 <- do
        if erased p -- WAS: (erased dec || p == Pol.Const)
         -- we have skipped an argument, so proceed with two types!
         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
           -- we have not skipped comparison, so proceed (1/2) as we came in
           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
               -- type is invariant, so it does not matter which one we take
      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
--    _ -> throwErrorMsg $ "leqVals': not (compatible) function types or mismatch number of arguments when comparing  " ++ show vl1 ++ "  to  " ++ show vl2 ++ "  at type  " ++ show tv12

{-
leqVals' f q (VPi x1 dom1@(Domain av1 _ dec1) env1 b1,
              VPi x2 dom2@(Domain av2 _ dec2) env2 b2)
         (w1:vs1) (w2:vs2) | dec1 == dec2 = do
  let p = polarity dec1
  v1 <- whnfClos w1
  v2 <- whnfClos w2
  when (not (erased dec1)) $
    applyDec dec1 $ leqVal' f (polComp p q) (Just (av1,av2)) v1 v2
  tv1 <- whnf (update env1 x1 v1) b1
  tv2 <- whnf (update env2 x2 v2) b2
  leqVals' f q (tv1,tv2) vs1 vs2
-}

{-
leqNe :: Force -> Val -> Val -> TypeCheck TVal
leqNe f v1 v2 = --trace ("leqNe " ++ show v1 ++ "<=" ++ show v2) $
  do case (v1,v2) of
      (VGen k1, VGen k2) -> if k1 == k2 then do
                                 dom <- lookupGem k1
                                 return $ typ dom
                               else throwErrorMsg $ "gen mismatch "  ++ show k1 ++ " " ++ show k2
-}

-- leqApp f pol v1 vs1 v2 vs2    checks   v1 vs1 <=pol v2 vs2
-- pol ::= Param | Pos | Neg
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 = {- trace ("leqApp: " -- ++ show delta ++ " |- "
                                  ++ show v1 ++ show w1 ++ " <=" ++ show pol ++ " " ++ show v2 ++ show w2) $ -}
{-
  do let headMismatch = recoverFail $
            "leqApp: head mismatch "  ++ show v1 ++ " != " ++ show v2
-}
  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
{-  IMPOSSIBLE:
      (VApp v1 [], v2) -> leqApp f pol v1 w1 v2 w2
      (v1, VApp v2 []) -> leqApp f pol v1 w1 v2 w2
-}
{-
      (VApp{}, _)    -> throwErrorMsg $ "leqApp: internal error: hit application v1 = " ++ show v1
      (_, VApp{})    -> throwErrorMsg $ "leqApp: internal error: hit application v2 = " ++ show v2
-}

      (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 ()
{-
      (VGen k1, VGen k2) ->
        if k1 /= k2
          then headMismatch
          else do tv12 <- (fmap typ . domain) <$> lookupGen k1
                  leqVals' f pol tv12 w1 w2
                  return ()
-}
{-
      (VCon _ n, VCon _ m) ->
        if n /= m
         then throwErrorMsg $
            "leqApp: head mismatch "  ++ show v1 ++ " != " ++ show v2
         else do
          sige <- lookupSymb n
          case sige of
            (ConSig tv) -> -- constructor
               leqVals' f tv (repeat mixed) 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 ()

      -- check for least or greatest type

      (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

{-
      -- least type
      (VDef (DefId DatK n), v2) | pol == Pos ->
        ifM (isEmptyData n) (return ()) headMismatch
      (v1, VDef (DefId DatK n)) | pol == Neg ->
        ifM (isEmptyData n) (return ()) headMismatch
-}
{-
      (VDef n, VDef m) ->
        if (name n) /= (name m) then do
           bot <- if pol==Neg then isEmptyData $ name m else
                  if pol==Pos then isEmptyData $ name n else return False
           if bot then return () else headMismatch
         else do
           tv <- lookupSymbTyp (name n)
           leqVals' f pol (One tv) w1 w2
           return ()
-}
{-
          sig <- gets signature
          case lookupSig (name n) sig of
            (DataSig{ numPars = p, positivity = pos, isSized = s, isCo = co, symbTyp = tv }) -> -- data type
               let positivitySizeIndex = if s /= Sized then mixed else
                                           if co == Ind then Pos else Neg
                   pos' = -- trace ("leqApp:  posOrig = " ++ show (pos ++ [positivitySizeIndex])) $
                     map (polComp pol) (pos ++ positivitySizeIndex : repeat mixed) -- the polComp will replace all SPos by Pos
               in leqVals' f tv pos' w1 w2
                    >> return ()

-- otherwise, we are dealing with a (co) recursive function or a constructor
            entry -> leqVals' f (symbTyp entry) (repeat mixed) w1 w2 >> return ()
-}

{-
      _ -> headMismatch

      _ -> recoverFail $ "leqApp: " ++ show v1 ++ show w1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ show w2
-}

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

-- comparing sorts and sizes -----------------------------------------

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 mixed s1 s2 = leqSort' s1 s2 >> leqSort' s2 s1
leqSort Neg s1 s2 = leqSort' s2 s1
leqSort Pos s1 s2 = leqSort' s1 s2
-}

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 = "universe test " ++ show s1 ++ " <= " ++ show s2 ++ " failed"
  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'

-- substaging on size values
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
$
-- enter ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show 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]
++ 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 () -- TODO: better handling of sums!
         (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
{-
         (VGen i1,VGen i2) -> do
           d <- getSizeDiff i1 i2 -- check size relation from constraints
           case d of
             Nothing -> recoverFail $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2
             Just k -> case (pol,k) of
               (_, 0) | pol == mixed -> return ()
               (Pos, _) | k >= 0 -> return ()
               (Neg, _) | k <= 0 -> return ()
               _ ->  recoverFail $ "leqSize: " ++ show v1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ " failed"
-}
{-
           if v1 == v2 then return ()
           else throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show 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 = -- enter ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show 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"
           -- err = "leSize': " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2 ++ " 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 -- all v in vs <= v2
         (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 -- this produces a disjunction
--         (_,VMax _)  -> addLe ltle v1 v2 -- this produces a disjunction
         (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
{-
         (0,VMeta i n', VMeta j m') ->
           let (n,m) = if bal <= 0 then (n', m' - bal) else (n' + bal, m') in
-}
         (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
{- HANDLED BY leSize'' ltle
         (VSucc{}, VGen{}) -> throwErrorMsg err
         (VSucc{}, VPlus{}) -> throwErrorMsg err
-}
-- leSize'' ltle bal v v'  checks whether  Succ^bal v `lt` v'
-- invariant: bal is zero in cases for VMax and VMeta
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
-- Only cancel variables < #
         _ | v1 == v2 && ltle == Le && bal <= 0 -> return ()
         (VGen i, VGen j) | i == j && bal <= -1 -> check $ isBelowInfty i
#else
-- Allow cancelling of all variables
         (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 () -- TODO: better handling of sums!
#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)
{-  2012-02-06 this modification cancels only variables < #
    However, omega-instantiation is valid [i < #] -> F i subseteq F #
    because every chain has a limit at #.
-}
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
      -- traceM ("getMinSize = " ++ show n)
      case n of
        Maybe Int
Nothing -> Bool
-> StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) ()
exit Bool
False -- height of VGen i == 0
        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)
-- recoverFail $ "leSize: head mismatch: " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2
        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

-- BAD HACK!
-- check (VGen i1) <= (VGen i2) + k
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

{-
leqSize' :: Val -> Val -> TypeCheck ()
leqSize' v1 v2 = --trace ("leqSize' " ++ show v1 ++ show v2) $
    do case (v1,v2) of
         (VMax vs,_) -> mapM_ (\ v -> leqSize' v v2) vs -- all v in vs <= v2
         (_,VMax _)  -> addLeq v1 v2 -- this produces a disjunction
         (VSucc v1,VSucc v2) -> leqSize' v1 v2
         (VGen v1,VGen v2) -> do
           d <- getSizeDiff v1 v2
           case d of
             Nothing -> throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2
             Just k -> if k >= 0 then return () else throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2 ++ " failed"
         (_,VInfty) -> return ()
         (VMeta i n, VSucc v2) | n > 0 -> leqSize' (VMeta i (n-1)) v2
         (VMeta i n, VMeta j m) -> addLeq (VMeta i (n - min n m))
                                          (VMeta j (m - min n m))
         (VMeta i n, v2) -> addLeq v1 v2
         (VSucc v1, VMeta i n) | n > 0 -> leqSize' v1 (VMeta i (n-1))
         (v1,VMeta i n) -> addLeq v1 v2
         (v1,VSucc v2) -> leqSize' v1 v2
         _ -> throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2
-}

-- measures and guards -----------------------------------------------

{-
-- compare lexicographically
-- precondition: same length
ltMeasure :: Measure Val -> Measure Val -> TypeCheck ()
ltMeasure  (Measure mu1) (Measure mu2) =
  -- enter ("checking " ++ show mu1 ++ " < " ++ show mu2) $
    lexSizes Lt mu1 mu2
-}

{-
leqMeasure :: Pol -> Measure Val -> Measure Val -> TypeCheck ()
leqMeasure mixed (Measure mu1) (Measure mu2) = do
  zipWithM (leqSize mixed) mu1 mu2
  return ()
leqMeasure Pos (Measure mu1) (Measure mu2) = lexSizes mu1 mu2
leqMeasure Neg (Measure mu1) (Measure mu2) = lexSizes mu2 mu1
-}

-- lexSizes True  mu mu' checkes mu <  mu'
-- lexSizes False mu mu' checkes mu <= mu'
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
            -- recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show 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

{-
      r <- compareSize a1 a2
      case r of
        LT -> return ()
        EQ -> lexSizes ltle mu1 mu2
        GT -> recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2
-}

{-
-- TODO: reprogram leqSize in terms of a proper compareSize
compareSize :: Val -> Val -> TypeCheck Ordering
compareSize a1 a2 = do
  let ret o = trace ("compareSize: " ++ show a1 ++ " compared to " ++ show a2 ++ " returns " ++ show o) $ return o
  le <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a1 a2
  ge <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a2 a1
  case (le,ge) of
    (True,False) -> ret LT -- THIS IS COMPLETE BOGUS!!!
    (True,True)  -> ret EQ
    (False,True) -> ret GT
    (False,False) -> throwErrorMsg $ "compareSize (" ++ show a1 ++ ", " ++ show a2 ++ "): sizes incomparable"
-}

{- Bound entailment

1. (mu1 <  mu1') ==> (mu2 <  mu2') if mu2 <= mu1 and mu1' <= mu2'
2. (mu1 <= mu1') ==> (mu2 <  mu2') one of these <= strict (<)
3. (mu1 <  mu1') ==> (mu2 <= mu2') as 1.
4. (mu1 <= mu1') ==> (mu2 <= mu2') as 1.

-}
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  -- not strictly smaller
      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

{-
eqGuard :: Bound Val -> Bound Val -> TypeCheck ()
eqGuard (Bound (Measure mu1) (Measure mu1')) (Bound (Measure mu2) (Measure mu2')) = do
  zipWithM (leqSize mixed) mu1 mu2
  zipWithM (leqSize mixed) mu1' mu2'
  return ()
-}

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

-- comparing polarities -------------------------------------------------

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

-- adding an edge to the positivity graph
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
  -- traceM ("adding interesting positivity graph edge  " ++ show src ++ " --[ " ++ show p ++ " ]--> " ++ show tgt)
  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
{-
  let solvable = all (\ x -> leqPol oone x)
  unless solvable $ recoverFail $ "positivity check failed"
-}
  -- TODO: solve constraints
  put $ st { positivityGraph = [] }

-- telescopes --------------------------------------------------------

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)

-- | Turn a fully applied constructor value into a named record value.
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