module Agda.TypeChecking.Free.Reduce
  ( ForceNotFree
  , forceNotFree
  , reallyFree
  , IsFree(..)
  ) where
import Prelude hiding (null)
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.IntMap as IntMap
import Data.IntMap (IntMap)
import qualified Data.IntSet as IntSet
import Data.IntSet (IntSet)
import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Free
import Agda.TypeChecking.Free.Precompute
import Agda.Utils.Monad
import Agda.Utils.Null
data IsFree
  = MaybeFree MetaSet
  | NotFree
  deriving (IsFree -> IsFree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsFree -> IsFree -> Bool
$c/= :: IsFree -> IsFree -> Bool
== :: IsFree -> IsFree -> Bool
$c== :: IsFree -> IsFree -> Bool
Eq, Int -> IsFree -> ShowS
[IsFree] -> ShowS
IsFree -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsFree] -> ShowS
$cshowList :: [IsFree] -> ShowS
show :: IsFree -> String
$cshow :: IsFree -> String
showsPrec :: Int -> IsFree -> ShowS
$cshowsPrec :: Int -> IsFree -> ShowS
Show)
forceNotFree :: (ForceNotFree a, Reduce a, MonadReduce m)
             => IntSet -> a -> m (IntMap IsFree, a)
forceNotFree :: forall a (m :: * -> *).
(ForceNotFree a, Reduce a, MonadReduce m) =>
IntSet -> a -> m (IntMap IsFree, a)
forceNotFree IntSet
xs a
a = do
  
  
  let mxs :: IntMap IsFree
mxs = forall a. (Int -> a) -> IntSet -> IntMap a
IntMap.fromSet (forall a b. a -> b -> a
const IsFree
NotFree) IntSet
xs
  (a
a, IntMap IsFree
mxs) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR forall a b. (a -> b) -> a -> b
$ forall a. PrecomputeFreeVars a => a -> a
precomputeFreeVars_ a
a) forall a. Monoid a => a
mempty) IntMap IsFree
mxs
  forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap IsFree
mxs, a
a)
reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a)
           => IntSet -> a -> m (Either Blocked_ (Maybe a))
reallyFree :: forall (m :: * -> *) a.
(MonadReduce m, Reduce a, ForceNotFree a) =>
IntSet -> a -> m (Either Blocked_ (Maybe a))
reallyFree IntSet
xs a
v = do
  (IntMap IsFree
mxs , a
v') <- forall a (m :: * -> *).
(ForceNotFree a, Reduce a, MonadReduce m) =>
IntSet -> a -> m (IntMap IsFree, a)
forceNotFree IntSet
xs a
v
  case forall a b. (a -> b -> b) -> b -> IntMap a -> b
IntMap.foldr IsFree -> IsFree -> IsFree
pickFree IsFree
NotFree IntMap IsFree
mxs of
    MaybeFree MetaSet
ms
      | forall a. Null a => a -> Bool
null MetaSet
ms   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
      | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall t a. Blocker -> a -> Blocked' t a
Blocked Blocker
blocker ()
      where blocker :: Blocker
blocker = MetaSet -> Blocker
metaSetToBlocker MetaSet
ms
    IsFree
NotFree -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just a
v')
  where
    
    
    pickFree :: IsFree -> IsFree -> IsFree
    pickFree :: IsFree -> IsFree -> IsFree
pickFree f1 :: IsFree
f1@(MaybeFree MetaSet
ms1) IsFree
f2
      | forall a. Null a => a -> Bool
null MetaSet
ms1  = IsFree
f1
    pickFree f1 :: IsFree
f1@(MaybeFree MetaSet
ms1) f2 :: IsFree
f2@(MaybeFree MetaSet
ms2)
      | forall a. Null a => a -> Bool
null MetaSet
ms2  = IsFree
f2
      | Bool
otherwise = IsFree
f1
    pickFree f1 :: IsFree
f1@(MaybeFree MetaSet
ms1) IsFree
NotFree = IsFree
f1
    pickFree IsFree
NotFree IsFree
f2 = IsFree
f2
type MonadFreeRed m =
  ( MonadReader MetaSet m
  , MonadState (IntMap IsFree) m
  , MonadReduce m
  )
class (PrecomputeFreeVars a, Subst a) => ForceNotFree a where
  
  
  
  
  
  forceNotFree' :: (MonadFreeRed m) => a -> m a
varsToForceNotFree :: (MonadFreeRed m) => m IntSet
varsToForceNotFree :: forall (m :: * -> *). MonadFreeRed m => m IntSet
varsToForceNotFree = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. IntMap a -> IntSet
IntMap.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter (forall a. Eq a => a -> a -> Bool
== IsFree
NotFree)))
reduceIfFreeVars :: (Reduce a, ForceNotFree a, MonadFreeRed m)
                 => (a -> m a) -> a -> m a
reduceIfFreeVars :: forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
(a -> m a) -> a -> m a
reduceIfFreeVars a -> m a
k a
a = do
  IntSet
xs <- forall (m :: * -> *). MonadFreeRed m => m IntSet
varsToForceNotFree
  let fvs :: IntSet
fvs     = forall a. PrecomputeFreeVars a => a -> IntSet
precomputedFreeVars a
a
      notfree :: Bool
notfree = IntSet -> IntSet -> Bool
IntSet.disjoint IntSet
xs IntSet
fvs
  if Bool
notfree
    then forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    else a -> m a
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrecomputeFreeVars a => a -> a
precomputeFreeVars_ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce a
a
forceNotFreeR :: (Reduce a, ForceNotFree a, MonadFreeRed m)
              => a -> m a
forceNotFreeR :: forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR = forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
(a -> m a) -> a -> m a
reduceIfFreeVars forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree'
instance (Reduce a, ForceNotFree a) => ForceNotFree (Arg a) where
  
  
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => Arg a -> m (Arg a)
forceNotFree' = forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
(a -> m a) -> a -> m a
reduceIfFreeVars (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree')
instance (Reduce a, ForceNotFree a, TermSubst a) => ForceNotFree (Dom a) where
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => Dom a -> m (Dom a)
forceNotFree' = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR
instance (Reduce a, ForceNotFree a) => ForceNotFree (Abs a) where
  
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => Abs a -> m (Abs a)
forceNotFree' a :: Abs a
a@NoAbs{} = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR Abs a
a
  forceNotFree' a :: Abs a
a@Abs{} =
    
    
    
    forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
(a -> m a) -> a -> m a
reduceIfFreeVars (forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeys forall a. Enum a => a -> a
succ) (\ ()
_ -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeys forall a. Enum a => a -> a
pred) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree') Abs a
a
instance ForceNotFree a => ForceNotFree [a] where
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => [a] -> m [a]
forceNotFree' = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree'
instance (Reduce a, ForceNotFree a) => ForceNotFree (Elim' a) where
  
  
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => Elim' a -> m (Elim' a)
forceNotFree' (Apply Arg a
arg)    = forall a. Arg a -> Elim' a
Apply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Arg a
arg
  forceNotFree' e :: Elim' a
e@Proj{}       = forall (m :: * -> *) a. Monad m => a -> m a
return Elim' a
e
  forceNotFree' (IApply a
x a
y a
r) = forall a. a -> a -> a -> Elim' a
IApply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR a
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR a
r
instance ForceNotFree Type where
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => Type -> m Type
forceNotFree' (El Sort' Term
s Term
t) = forall t a. Sort' t -> a -> Type'' t a
El forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Sort' Term
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Term
t
instance ForceNotFree Term where
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => Term -> m Term
forceNotFree' = \case
    Var Int
x Elims
es   -> do
      MetaSet
metas <- forall r (m :: * -> *). MonadReader r m => m r
ask
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IntMap.adjust (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ MetaSet -> IsFree
MaybeFree MetaSet
metas) Int
x
      Int -> Elims -> Term
Var Int
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Elims
es
    Def QName
f Elims
es   -> QName -> Elims -> Term
Def QName
f    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Elims
es
    Con ConHead
c ConInfo
h Elims
es -> ConHead -> ConInfo -> Elims -> Term
Con ConHead
c ConInfo
h  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Elims
es
    MetaV MetaId
x Elims
es -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (MetaId -> MetaSet -> MetaSet
insertMetaSet MetaId
x) forall a b. (a -> b) -> a -> b
$
                  MetaId -> Elims -> Term
MetaV MetaId
x  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Elims
es
    Lam ArgInfo
h Abs Term
b    -> ArgInfo -> Abs Term -> Term
Lam ArgInfo
h    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Abs Term
b
    Pi Dom Type
a Abs Type
b     -> Dom Type -> Abs Type -> Term
Pi       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Dom Type
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Abs Type
b  
    Sort Sort' Term
s     -> Sort' Term -> Term
Sort     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Sort' Term
s
    Level Level
l    -> Level -> Term
Level    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Level
l
    DontCare Term
t -> Term -> Term
DontCare forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(Reduce a, ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFreeR Term
t  
    t :: Term
t@Lit{}    -> forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
    t :: Term
t@Dummy{}  -> forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
instance ForceNotFree Level where
  forceNotFree' :: forall (m :: * -> *). MonadFreeRed m => Level -> m Level
forceNotFree' (Max Integer
m [PlusLevel' Term]
as) = forall t. Integer -> [PlusLevel' t] -> Level' t
Max Integer
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' [PlusLevel' Term]
as
instance ForceNotFree PlusLevel where
  forceNotFree' :: forall (m :: * -> *).
MonadFreeRed m =>
PlusLevel' Term -> m (PlusLevel' Term)
forceNotFree' (Plus Integer
k Term
a) = forall t. Integer -> t -> PlusLevel' t
Plus Integer
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Term
a
instance ForceNotFree Sort where
  
  
  forceNotFree' :: forall (m :: * -> *).
MonadFreeRed m =>
Sort' Term -> m (Sort' Term)
forceNotFree' = \case
    Type Level
l     -> forall t. Level' t -> Sort' t
Type     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Level
l
    Prop Level
l     -> forall t. Level' t -> Sort' t
Prop     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Level
l
    SSet Level
l     -> forall t. Level' t -> Sort' t
SSet     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Level
l
    PiSort Dom' Term Term
a Sort' Term
b Abs (Sort' Term)
c -> forall t. Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t
PiSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Dom' Term Term
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Sort' Term
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Abs (Sort' Term)
c
    FunSort Sort' Term
a Sort' Term
b -> forall t. Sort' t -> Sort' t -> Sort' t
FunSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Sort' Term
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Sort' Term
b
    UnivSort Sort' Term
s -> forall t. Sort' t -> Sort' t
UnivSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Sort' Term
s
    MetaS MetaId
x Elims
es -> forall t. MetaId -> [Elim' t] -> Sort' t
MetaS MetaId
x  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Elims
es
    DefS QName
d Elims
es  -> forall t. QName -> [Elim' t] -> Sort' t
DefS QName
d   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(ForceNotFree a, MonadFreeRed m) =>
a -> m a
forceNotFree' Elims
es
    s :: Sort' Term
s@(Inf IsFibrant
_ Integer
_)-> forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
    s :: Sort' Term
s@Sort' Term
SizeUniv -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
    s :: Sort' Term
s@Sort' Term
LockUniv -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
    s :: Sort' Term
s@Sort' Term
IntervalUniv -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
    s :: Sort' Term
s@DummyS{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s